more layering cleanup: BreakArray should come from GHC

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index a1aaa6a..3e528d0 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -79,17 +79,12 @@ import Control.Monad as Monad
 
 import Foreign.StablePtr       ( newStablePtr )
 import GHC.Exts                ( unsafeCoerce# )
 
 import Foreign.StablePtr       ( newStablePtr )
 import GHC.Exts                ( unsafeCoerce# )

-import GHC.IOBase      ( IOErrorType(InvalidArgument), IO(IO) )
+import GHC.IOBase      ( IOErrorType(InvalidArgument) )

 
 import Data.IORef      ( IORef, readIORef, writeIORef )
 
 import System.Posix.Internals ( setNonBlockingFD )
 
 
 import Data.IORef      ( IORef, readIORef, writeIORef )
 
 import System.Posix.Internals ( setNonBlockingFD )
 

--- these are needed by the new ghci debugger
-import ByteCodeLink (HValue)
-import ByteCodeInstr (BreakInfo (..))
-import BreakArray
-

 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg =
 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg =

@@ -109,14 +104,14 @@ builtin_commands = [
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("?",                keepGoing help,                 False, completeNone),
   ("add",      keepGoingPaths addModule,       False, completeFilename),
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("?",                keepGoing help,                 False, completeNone),
   ("add",      keepGoingPaths addModule,       False, completeFilename),

-  ("break",     breakCmd, False, completeNone),   
+  ("break",     breakCmd,                       False, completeIdentifier),

   ("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",  continueCmd,                    False, completeNone),

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

-  ("delete",    deleteCmd, False, completeNone),   
+  ("delete",    deleteCmd,                      False, completeNone),

   ("e",        keepGoing editFile,             False, completeFilename),
   ("edit",     keepGoing editFile,             False, completeFilename),
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
   ("e",        keepGoing editFile,             False, completeFilename),
   ("edit",     keepGoing editFile,             False, completeFilename),
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),

@@ -124,7 +119,7 @@ builtin_commands = [
   ("help",     keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("help",     keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),

-  ("load",     keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
+  ("load",     keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),

   ("module",   keepGoing setContext,           False, completeModule),
   ("main",     keepGoing runMain,              False, completeIdentifier),
   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
   ("module",   keepGoing setContext,           False, completeModule),
   ("main",     keepGoing runMain,              False, completeIdentifier),
   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),

@@ -133,7 +128,7 @@ builtin_commands = [
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),

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

   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions)
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions)

@@ -147,24 +142,32 @@ keepGoingPaths a str = a (toArgs str) >> return False
 
 shortHelpText = "use :? for help.\n"
 
 
 shortHelpText = "use :? for help.\n"
 

--- NOTE: spaces at the end of each line to workaround CPP/string gap bug.

 helpText =
  " Commands available from the prompt:\n" ++
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++
 helpText =
  " Commands available from the prompt:\n" ++
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\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" ++
  "   :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" ++
  "   :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" ++
  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++

- "   :print [<name> ...]         prints a value without forcing its computation\n" ++
- "   :sprint [<name> ...]        simplified version of :print\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" ++
  "   :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" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
  "   :reload                     reload the current module set\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++

@@ -173,16 +176,17 @@ helpText =
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
  "   :set editor <cmd>           set the command used for :edit\n" ++
  "\n" ++
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
  "   :set editor <cmd>           set the command used for :edit\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" ++
  "   :show modules               show the currently loaded modules\n" ++
  "   :show bindings              show the current bindings made at the prompt\n" ++
  "\n" ++

- "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
- "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\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" ++
  "   :type <expr>                show the type of <expr>\n" ++

- "   :kind <type>                show the kind of <type>\n" ++

  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
  "   :unset <option> ...         unset options\n" ++
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
  "   :unset <option> ...         unset options\n" ++

- "   :quit                       exit GHCi\n" ++

  "   :!<command>                 run the shell command <command>\n" ++
  "\n" ++
  " Options for ':set' and ':unset':\n" ++
  "   :!<command>                 run the shell command <command>\n" ++
  "\n" ++
  " Options for ':set' and ':unset':\n" ++

@@ -1200,7 +1204,8 @@ showCmd str =
        ["bindings"] -> showBindings
        ["linker"]   -> io showLinkerState
         ["breaks"] -> showBkptTable
        ["bindings"] -> showBindings
        ["linker"]   -> io showLinkerState
         ["breaks"] -> showBkptTable

-       _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
+        ["context"] -> showContext
+       _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings|breaks]")

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

@@ -1234,6 +1239,13 @@ showBkptTable = do
    activeBreaks <- getActiveBreakPoints 
    printForUser $ ppr activeBreaks 
 
    activeBreaks <- getActiveBreakPoints 
    printForUser $ ppr activeBreaks 
 

+showContext :: GHCi ()
+showContext = do
+   st <- getGHCiState
+   printForUser $ vcat (map pp_resume (resume st))
+  where
+   pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
+

 -- -----------------------------------------------------------------------------
 -- Completion
 
 -- -----------------------------------------------------------------------------
 -- Completion
 

@@ -1487,29 +1499,43 @@ breakCmd :: String -> GHCi Bool
 breakCmd argLine = do
    session <- getSession
    breakSwitch session $ words argLine
 breakCmd argLine = do
    session <- getSession
    breakSwitch session $ words argLine

+   return False

 
 

-breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch :: Session -> [String] -> GHCi ()

 breakSwitch _session [] = do
    io $ putStrLn "The break command requires at least one argument."
 breakSwitch _session [] = do
    io $ putStrLn "The break command requires at least one argument."

-   return False

 breakSwitch session args@(arg1:rest) 
 breakSwitch session args@(arg1:rest) 

-   | looksLikeModule arg1 = do
+   | looksLikeModuleName arg1 = do

         mod <- wantInterpretedModule session arg1
         mod <- wantInterpretedModule session arg1

-        breakByModule mod rest
-        return False
-   | otherwise = do
+        breakByModule session mod rest
+   | all isDigit arg1 = do

         (toplevel, _) <- io $ GHC.getContext session 
         case toplevel of
         (toplevel, _) <- io $ GHC.getContext session 
         case toplevel of

-           (mod : _) -> breakByModule mod args 
+           (mod : _) -> breakByModuleLine mod (read arg1) rest

            [] -> do 
               io $ putStrLn "Cannot find default module for breakpoint." 
               io $ putStrLn "Perhaps no modules are loaded for debugging?"
            [] -> do 
               io $ putStrLn "Cannot find default module for breakpoint." 
               io $ putStrLn "Perhaps no modules are loaded for debugging?"

-        return False
-   where
-   -- Todo there may be a nicer way to test this
-   looksLikeModule :: String -> Bool
-   looksLikeModule []    = False
-   looksLikeModule (x:_) = isUpper x
+   | otherwise = do -- assume it's a name
+        names <- io $ GHC.parseName session arg1
+        case names of
+          []    -> return ()
+          (n:_) -> do
+            let loc  = nameSrcLoc n
+                modl = nameModule n
+            is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+            if not is_interpreted
+               then noCanDo $ text "module " <> ppr modl <>
+                              text " is not interpreted"
+               else do
+            if isGoodSrcLoc loc
+               then findBreakAndSet (nameModule n) $ 
+                         findBreakByCoord (srcLocLine loc, srcLocCol loc)
+               else noCanDo $ text "can't find its location: " <>
+                              ppr loc
+           where
+             noCanDo why = printForUser $
+                text "cannot set breakpoint on " <> ppr n <> text ": " <> why
+

 
 wantInterpretedModule :: Session -> String -> GHCi Module
 wantInterpretedModule session str = do
 
 wantInterpretedModule :: Session -> String -> GHCi Module
 wantInterpretedModule session str = do

@@ -1519,26 +1545,18 @@ wantInterpretedModule session str = do
        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
    return modl
 
        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
    return modl
 

-breakByModule :: Module -> [String] -> GHCi () 
-breakByModule mod args@(arg1:rest)
+breakByModule :: Session -> Module -> [String] -> GHCi () 
+breakByModule session mod args@(arg1:rest)

    | all isDigit arg1 = do  -- looks like a line number
         breakByModuleLine mod (read arg1) rest
    | all isDigit arg1 = do  -- looks like a line number
         breakByModuleLine mod (read arg1) rest

-   | looksLikeVar arg1 = do
-        -- break by a function definition
-        io $ putStrLn "Break by function definition not implemented."
-   | otherwise = io $ putStrLn "Invalid arguments to break command."
-   where
-   -- Todo there may be a nicer way to test this
-   looksLikeVar :: String -> Bool
-   looksLikeVar [] = False
-   looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
+   | otherwise = io $ putStrLn "Invalid arguments to :break"

 
 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
 breakByModuleLine mod line args
    | [] <- args = findBreakAndSet mod $ findBreakByLine line
    | [col] <- args, all isDigit col =
         findBreakAndSet mod $ findBreakByCoord (line, read col)
 
 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
 breakByModuleLine mod line args
    | [] <- args = findBreakAndSet mod $ findBreakByLine line
    | [col] <- args, all isDigit col =
         findBreakAndSet mod $ findBreakByCoord (line, read col)

-   | otherwise = io $ putStrLn "Invalid arguments to break command."
+   | otherwise = io $ putStrLn "Invalid arguments to :break"

 
 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
 findBreakAndSet mod lookupTickTree = do 
 
 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
 findBreakAndSet mod lookupTickTree = do 

@@ -1573,10 +1591,12 @@ findBreakAndSet mod lookupTickTree = do
 --    - the rightmost subexpression enclosing the specified line
 --
 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
 --    - the rightmost subexpression enclosing the specified line
 --
 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)

-findBreakByLine line arr = 
-  listToMaybe (sortBy leftmost complete)   `mplus`
-  listToMaybe (sortBy leftmost incomplete) `mplus`
-  listToMaybe (sortBy rightmost ticks)
+findBreakByLine line arr
+  | not (inRange (bounds arr) line) = Nothing
+  | otherwise =
+    listToMaybe (sortBy leftmost complete)   `mplus`
+    listToMaybe (sortBy leftmost incomplete) `mplus`
+    listToMaybe (sortBy rightmost ticks)

   where 
         ticks = arr ! line
 
   where 
         ticks = arr ! line
 

@@ -1587,8 +1607,10 @@ findBreakByLine line arr =
             where ends_here (nm,span) = srcSpanEndLine span == line
 
 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
             where ends_here (nm,span) = srcSpanEndLine span == line
 
 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)

-findBreakByCoord (line, col) arr =
-  listToMaybe (sortBy rightmost contains)
+findBreakByCoord (line, col) arr
+  | not (inRange (bounds arr) line) = Nothing
+  | otherwise =
+    listToMaybe (sortBy rightmost contains)

   where 
         ticks = arr ! line
 
   where 
         ticks = arr ! line
 

@@ -1632,7 +1654,7 @@ mkTickArray ticks
         max_line = maximum (map srcSpanEndLine (map snd ticks))
         srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
 
         max_line = maximum (map srcSpanEndLine (map snd ticks))
         srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
 

-getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)

 getModBreak mod = do
    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session mod
 getModBreak mod = do
    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session mod

@@ -1645,10 +1667,10 @@ lookupModule :: Session -> String -> GHCi Module
 lookupModule session modName
    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
 
 lookupModule session modName
    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
 

-setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool 
+setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool 

 setBreakFlag toggle array index
 setBreakFlag toggle array index

-   | toggle    = setBreakOn array index 
-   | otherwise = setBreakOff array index
+   | toggle    = GHC.setBreakOn array index 
+   | otherwise = GHC.setBreakOff array index

 
 
 {- these should probably go to the GHC API at some point -}
 
 
 {- these should probably go to the GHC API at some point -}