X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=4a98b9e60a1210e700854f1ce9a1a3e0e5c0f75e;hb=38e7ac3ffa32d75c1922e7247a910e06d9957116;hp=3fbdcbe576bf4c11b8e46331b72b1986cef9d2c7;hpb=4c61d9effc9117497cd59a050856c01d8bbf24aa;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 3fbdcbe..4a98b9e 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -18,13 +18,16 @@ import GhciMonad
 -- The GHC interface
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
-                          Type, Module, ModuleName, TyThing(..), Phase )
+                          Type, Module, ModuleName, TyThing(..), Phase,
+                          BreakIndex )
+import Debugger
 import DynFlags
 import Packages
 import PackageConfig
 import UniqFM
 import PprTyThing
 import Outputable
+import Module           -- for ModuleEnv
 
 -- for createtags
 import Name
@@ -40,19 +43,6 @@ import StaticFlags
 import Linker
 import Util
 
--- The debugger
-import Breakpoints
-import Debugger hiding  ( addModule )
-import HscTypes
-import Id
-import Var       ( globaliseId )
-import IdInfo
-import NameEnv
-import RdrName
-import Module
-import Type
-import TcType
-
 #ifndef mingw32_HOST_OS
 import System.Posix
 #if __GLASGOW_HASKELL__ > 504
@@ -74,10 +64,8 @@ import System.Console.Readline as Readline
 import Control.Exception as Exception
 -- import Control.Concurrent
 
-import Numeric
 import Data.List
-import Data.Int		( Int64 )
-import Data.Maybe	( isJust, isNothing, fromMaybe, catMaybes )
+import Data.Maybe
 import System.Cmd
 import System.Environment
 import System.Exit	( exitWith, ExitCode(..) )
@@ -86,16 +74,22 @@ import System.IO
 import System.IO.Error as IO
 import Data.Char
 import Data.Dynamic
+import Data.Array
 import Control.Monad as Monad
-import Foreign.StablePtr	( newStablePtr )
 
+import Foreign.StablePtr	( newStablePtr )
 import GHC.Exts		( unsafeCoerce# )
-import GHC.IOBase	( IOErrorType(InvalidArgument) )
+import GHC.IOBase	( IOErrorType(InvalidArgument), IO(IO) )
 
-import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
+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 =
@@ -112,49 +106,42 @@ GLOBAL_VAR(commands, builtin_commands, [Command])
 
 builtin_commands :: [Command]
 builtin_commands = [
-  ("add",	tlC$ 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),   
   ("browse",    keepGoing browseCmd,		False, completeModule),
   ("cd",    	keepGoing changeDirectory,	False, completeFilename),
+  ("check",	keepGoing checkModule,		False, completeHomeModule),
+  ("continue",  continueCmd, False, completeNone),
+  ("ctags",	keepGoing createCTagsFileCmd, 	False, completeFilename),
   ("def",	keepGoing defineMacro,		False, completeIdentifier),
+  ("delete",    deleteCmd, False, completeNone),   
   ("e", 	keepGoing editFile,		False, completeFilename),
-	-- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("edit",	keepGoing editFile,		False, completeFilename),
+  ("etags",	keepGoing createETagsFileCmd,	False, completeFilename),
+  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
   ("help",	keepGoing help,			False, completeNone),
-  ("?",		keepGoing help,			False, completeNone),
   ("info",      keepGoing info,			False, completeIdentifier),
-  ("load",	tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
+  ("kind",	keepGoing kindOfType,		False, completeIdentifier),
+  ("load",	keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
   ("module",	keepGoing setContext,		False, completeModule),
-  ("main",	tlC$ keepGoing runMain,		False, completeIdentifier),
-  ("reload", 	tlC$ keepGoing reloadModule,  	False, completeNone),
-  ("check",	keepGoing checkModule,		False, completeHomeModule),
+  ("main",	keepGoing runMain,		False, completeIdentifier),
+  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+  ("quit",	quit,				False, completeNone),
+  ("reload", 	keepGoing reloadModule,  	False, completeNone),
   ("set",	keepGoing setCmd,		True,  completeSetOptions),
   ("show",	keepGoing showCmd,		False, completeNone),
-  ("etags",	keepGoing createETagsFileCmd,	False, completeFilename),
-  ("ctags",	keepGoing createCTagsFileCmd, 	False, completeFilename),
-  ("type",	keepGoing typeOfExpr,		False, completeIdentifier),
-#if defined(DEBUGGER)
-  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
-  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
-  ("breakpoint",keepGoing bkptOptions,          False, completeBkpt),
-#endif
-  ("kind",	keepGoing kindOfType,		False, completeIdentifier),
-  ("unset",	keepGoing unsetOptions,		True,  completeSetOptions),
+  ("step",      stepCmd, False, completeNone), 
+  ("type",	keepGoing typeOfExpr,		False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,	False, completeMacro),
-  ("quit",	quit,				False, completeNone)
+  ("unset",	keepGoing unsetOptions,		True,  completeSetOptions)
   ]
 
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 
--- tlC: Top Level Command
-tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
-tlC a str = do 
-    top_level <- isTopLevel
-    if not top_level
-       then throwDyn (CmdLineError "Command only allowed at Top Level")
-       else a str
-
 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 keepGoingPaths a str = a (toArgs str) >> return False
 
@@ -166,7 +153,6 @@ helpText =
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++
- "   :breakpoint <option>        commands for the GHCi debugger\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
@@ -206,13 +192,8 @@ helpText =
  "    +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" ++
- " Options for ':breakpoint':\n" ++
- "   list                                     list the current breakpoints\n" ++
- "   add Module line [col]                    add a new breakpoint\n" ++
- "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++
- "   stop                   Stop a computation and return to the top level\n" ++
- "   step [count]           Step by step execution (DISABLED)\n"
+ "\n" 
+-- Todo: add help for breakpoint commands here
 
 findEditor = do
   getEnv "EDITOR" 
@@ -253,7 +234,7 @@ interactiveUI session srcs maybe_expr = do
 	hSetBuffering stdin NoBuffering
 
 	-- initial context is just the Prelude
-   prel_mod <- GHC.findModule session prel_name Nothing
+   prel_mod <- GHC.findModule session prel_name (Just basePackageId)
    GHC.setContext session [] [prel_mod]
 
 #ifdef USE_READLINE
@@ -270,8 +251,6 @@ interactiveUI session srcs maybe_expr = do
    Readline.setCompleterWordBreakCharacters word_break_chars
 #endif
 
-   bkptTable <- newIORef emptyBkptTable
-   GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
    default_editor <- findEditor
 
    startGHCi (runGHCi srcs maybe_expr)
@@ -282,8 +261,9 @@ interactiveUI session srcs maybe_expr = do
 		   session = session,
 		   options = [],
                    prelude = prel_mod,
-                   bkptTable = bkptTable,
-		   topLevel  = True
+                   resume = [],
+                   breaks = emptyActiveBreakPoints,
+                   tickarrays = emptyModuleEnv
                  }
 
 #ifdef USE_READLINE
@@ -464,7 +444,7 @@ mkPrompt toplevs exports prompt
     
         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
                  hsep (map (ppr . GHC.moduleName) exports)
-             
+
 
 #ifdef USE_READLINE
 readlineLoop :: GHCi ()
@@ -515,26 +495,44 @@ runCommandEval c = ghciHandle handleEval (doCommand c)
 		  -- failure to run the command causes exit(1) for ghc -e.
 		_       -> finishEvalExpr nms
 
-runStmt :: String -> GHCi (Maybe [Name])
+runStmt :: String -> GHCi (Maybe (Bool,[Name]))
 runStmt stmt
- | null (filter (not.isSpace) stmt) = return (Just [])
+ | null (filter (not.isSpace) stmt) = return (Just (False,[]))
  | otherwise
  = do st <- getGHCiState
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $
 	     	     GHC.runStmt session stmt
-      case result of
-	GHC.RunFailed      -> return Nothing
-	GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
-	GHC.RunOk names    -> return (Just names)
+      switchOnRunResult result
+
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
+switchOnRunResult GHC.RunFailed = return Nothing
+switchOnRunResult (GHC.RunException e) = throw e
+switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
+switchOnRunResult (GHC.RunBreak threadId names info resume) = do
+   session <- getSession
+   Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info) 
+   let modBreaks  = GHC.modInfoModBreaks mod_info
+   let ticks      = GHC.modBreaks_locs modBreaks
+
+   -- display information about the breakpoint
+   let location = ticks ! breakInfo_number info
+   unqual <- io $ GHC.getPrintUnqual session
+   io $ printForUser stdout unqual $
+      ptext SLIT("Stopped at") <+> ppr location
+
+   pushResume location threadId resume
+   return (Just (True,names))
 
 -- possibly print the type and revert CAFs after evaluating an expression
 finishEvalExpr mb_names
- = do b <- isOptionSet ShowType
+ = do show_types <- isOptionSet ShowType
       session <- getSession
       case mb_names of
 	Nothing    -> return ()      
-	Just names -> when b (mapM_ (showTypeOfName session) names)
+	Just (is_break,names) -> 
+                when (is_break || show_types) $
+                      mapM_ (showTypeOfName session) names
 
       flushInterpBuffers
       io installSignalHandlers
@@ -769,10 +767,12 @@ reloadModule m = do
 
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
+  discardResumeContext
+  discardTickArrays
+  discardActiveBreakPoints
   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
-  refreshBkptTable graph'
   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 
 setContextAfterLoad session [] = do
@@ -841,7 +841,7 @@ kindOfType str
 	  Nothing    -> return ()
 	  Just ty    -> do tystr <- showForUser (ppr ty)
 		           io (putStrLn (str ++ " :: " ++ tystr))
-
+          
 quit :: String -> GHCi Bool
 quit _ = return True
 
@@ -972,10 +972,8 @@ browseCmd m =
 
 browseModule m exports_only = do
   s <- getSession
-  modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
-  is_interpreted <- io (GHC.moduleIsInterpreted s modl)
-  when (not is_interpreted && not exports_only) $
-	throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+  modl <- if exports_only then lookupModule s m
+                          else wantInterpretedModule s m
 
   -- Temporarily set the context to the module we're interested in,
   -- just so we can get an appropriate PrintUnqualified
@@ -1205,7 +1203,7 @@ showCmd str =
 	["modules" ] -> showModules
 	["bindings"] -> showBindings
 	["linker"]   -> io showLinkerState
-        ["breakpoints"] -> showBkptTable
+        ["breaks"] -> showBkptTable
 	_ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 
 showModules = do
@@ -1238,12 +1236,10 @@ cleanType ty = do
 
 showBkptTable :: GHCi ()
 showBkptTable = do
-  bt     <- getBkptTable
-  msg <- showForUser . vcat $ 
-             [ ppr mod <> colon <+> fcat 
-                       [ parens(int row <> comma <> int col) | (row,col) <- sites]
-               | (mod, sites) <-  sitesList bt ]
-  io (putStrLn msg)
+   activeBreaks <- getActiveBreakPoints 
+   str <- showForUser $ ppr activeBreaks 
+   io $ putStrLn str
+
 -- -----------------------------------------------------------------------------
 -- Completion
 
@@ -1315,12 +1311,6 @@ completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)
     where options = "args":"prog":allFlags
 
-completeBkpt = unionComplete completeModule completeBkptCmds
-
-completeBkptCmds w = do
-  return (filter (w `isPrefixOf`) options)
-    where options = ["add","del","list","stop"]
-
 completeFilename = Readline.filenameCompletionFunction
 
 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
@@ -1344,7 +1334,7 @@ wrapCompleter fun w =  do
 getCommonPrefix :: [String] -> String
 getCommonPrefix [] = ""
 getCommonPrefix (s:ss) = foldl common s ss
-  where common s "" = s
+  where common s "" = ""
 	common "" s = ""
 	common (c:cs) (d:ds)
 	   | c == d = c : common cs ds
@@ -1381,16 +1371,6 @@ completeBkpt       = completeNone
 -- handler arond the flushing operation, so if stderr is closed
 -- GHCi will just die gracefully rather than going into an infinite loop.
 handler :: Exception -> GHCi Bool
-handler (DynException dyn) 
-  | Just StopChildSession <- fromDynamic dyn 
-     -- propagate to the parent session
-  = do ASSERTM (liftM not isTopLevel) 
-       throwDyn StopChildSession
-
-  | Just (ChildSessionStopped msg) <- fromDynamic dyn 
-     -- Reload modules and display some message
-  = do ASSERTM (isTopLevel) 
-       io(putStrLn msg) >> return False
 
 handler exception = do
   flushInterpBuffers
@@ -1460,83 +1440,237 @@ setUpConsole = do
 #endif
 	return ()
 
+-- commands for debugger
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
+
+stepCmd :: String -> GHCi Bool
+stepCmd [] = doContinue setStepFlag 
+stepCmd expression = do
+   io $ setStepFlag
+   runCommand expression
+
+continueCmd :: String -> GHCi Bool
+continueCmd [] = doContinue $ return () 
+continueCmd other = do
+   io $ putStrLn "The continue command accepts no arguments."
+   return False
+
+doContinue :: IO () -> GHCi Bool
+doContinue actionBeforeCont = do 
+   resumeAction <- popResume
+   case resumeAction of
+      Nothing -> do 
+         io $ putStrLn "There is no computation running."
+         return False
+      Just (_,_,handle) -> do
+         io $ actionBeforeCont
+         session <- getSession
+         runResult <- io $ GHC.resume session handle
+         names <- switchOnRunResult runResult
+         finishEvalExpr names
+         return False 
+
+deleteCmd :: String -> GHCi Bool
+deleteCmd argLine = do
+   deleteSwitch $ words argLine
+   return False
+   where
+   deleteSwitch :: [String] -> GHCi ()
+   deleteSwitch [] = 
+      io $ putStrLn "The delete command requires at least one argument."
+   -- delete all break points
+   deleteSwitch ("*":_rest) = discardActiveBreakPoints
+   deleteSwitch idents = do
+      mapM_ deleteOneBreak idents 
+      where
+      deleteOneBreak :: String -> GHCi ()
+      deleteOneBreak str
+         | all isDigit str = deleteBreak (read str)
+         | otherwise = return ()
+
+-- handle the "break" command
+breakCmd :: String -> GHCi Bool
+breakCmd argLine = do
+   session <- getSession
+   breakSwitch session $ words argLine
+
+breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch _session [] = do
+   io $ putStrLn "The break command requires at least one argument."
+   return False
+breakSwitch session args@(arg1:rest) 
+   | looksLikeModule arg1 = do
+        mod <- wantInterpretedModule session arg1
+        breakByModule mod rest
+        return False
+   | otherwise = do
+        (toplevel, _) <- io $ GHC.getContext session 
+        case toplevel of
+           (mod : _) -> breakByModule mod args 
+           [] -> 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
+
+wantInterpretedModule :: Session -> String -> GHCi Module
+wantInterpretedModule session str = do
+   modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+   is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+   when (not is_interpreted) $
+       throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+   return modl
+
+breakByModule :: Module -> [String] -> GHCi () 
+breakByModule mod args@(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` "~!@#$%^&*-+"
+
+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."
+
+findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet mod lookupTickTree = do 
+   tickArray <- getTickArray mod
+   (breakArray, _) <- getModBreak mod
+   case lookupTickTree tickArray of 
+      Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
+      Just (tick, span) -> do
+         success <- io $ setBreakFlag True breakArray tick 
+         session <- getSession
+         unqual  <- io $ GHC.getPrintUnqual session
+         if success 
+            then do
+               (alreadySet, nm) <- 
+                     recordBreak $ BreakLocation
+                             { breakModule = mod
+                             , breakLoc = span
+                             , breakTick = tick
+                             }
+               io $ printForUser stdout unqual $
+                  text "Breakpoint " <> ppr nm <>
+                  if alreadySet 
+                     then text " was already set at " <> ppr span
+                     else text " activated at " <> ppr span
+            else do
+            str <- showForUser $ text "Breakpoint could not be activated at" 
+                                 <+> ppr span
+            io $ putStrLn str
+
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+--    - the leftmost complete subexpression on the specified line, or
+--    - the leftmost subexpression starting on the specified line, or
+--    - 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)
+  where 
+        ticks = arr ! line
+
+        starts_here = [ tick | tick@(nm,span) <- ticks,
+                               srcSpanStartLine span == line ]
 
-instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
-instrumentationBkptHandler ref_bkptTable = BkptHandler {
-    isAutoBkptEnabled = \sess bkptLoc -> do 
-      bktpTable <- readIORef ref_bkptTable
-      return$ isBkptEnabled bktpTable bkptLoc
-
-  , handleBreakpoint = doBreakpoint ref_bkptTable 
-  }
-
-doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
-doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
-         let (ids, hValues) = unzip values
-             names = map idName ids
-         ASSERT (length names == length hValues) return ()
-         let global_ids = map globaliseAndTidy ids
-         printScopeMsg locMsg global_ids
-         typed_ids  <- mapM instantiateIdType global_ids
-         hsc_env <- readIORef ref
-         let ictxt = hsc_IC hsc_env
-             rn_env   = ic_rn_local_env ictxt
-             type_env = ic_type_env ictxt
-             bound_names = map idName typed_ids
-             new_rn_env  = extendLocalRdrEnv rn_env bound_names
-		-- Remove any shadowed bindings from the type_env;
-		-- they are inaccessible but might, I suppose, cause 
-		-- a space leak if we leave them there
-             shadowed = [ n | name <- bound_names,
-                          let rdr_name = mkRdrUnqual (nameOccName name),
-                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
-             filtered_type_env = delListFromNameEnv type_env shadowed
-             new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
-             new_ic = ictxt { ic_rn_local_env = new_rn_env, 
-		  	      ic_type_env     = new_type_env }
-         writeIORef ref (hsc_env { hsc_IC = new_ic })
-         is_tty <- hIsTerminalDevice stdin
-         prel_mod <- GHC.findModule s prel_name Nothing
-         withExtendedLinkEnv (zip names hValues) $ 
-           startGHCi (interactiveLoop is_tty True) GHCiState{ 
-                              progname = "<interactive>",
-                              args     = [],
-                              prompt   = locMsg ++ "> ",
-                              session  = s,
-                              options  = [],
-                              bkptTable= ref_bkptTable,
-                              prelude  = prel_mod,
-			      topLevel = False }
-             `catchDyn` (
-                 \StopChildSession -> evaluate$
-                        throwDyn (ChildSessionStopped "")
-           ) `finally` do
-             writeIORef ref hsc_env
-             putStrLn $ "Returning to normal execution..."
-         return b
+        (complete,incomplete) = partition ends_here starts_here
+            where ends_here (nm,span) = srcSpanEndLine span == line
+
+findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord (line, col) arr =
+  listToMaybe (sortBy rightmost contains)
   where 
-     printScopeMsg :: String -> [Id] -> IO ()
-     printScopeMsg location ids = do
-       unqual  <- GHC.getPrintUnqual s
-       printForUser stdout unqual $
-         text "Stopped at a breakpoint in " <> text (stripColumn location) <>
-         char '.' <+> text "Local bindings in scope:" $$
-         nest 2 (pprWithCommas showId ids)
-      where 
-           showId id = 
-                ppr (idName id) <+> dcolon <+> ppr (idType id) 
-           stripColumn = reverse . tail . dropWhile (/= ':') . reverse
-
--- | Give the Id a Global Name, and tidy its type
-     globaliseAndTidy :: Id -> Id
-     globaliseAndTidy id
-      = let tidied_type = tidyTopType$ idType id
-        in setIdType (globaliseId VanillaGlobal id) tidied_type
-
--- | Instantiate the tyVars with GHC.Base.Unknown
-     instantiateIdType :: Id -> IO Id
-     instantiateIdType id = do
-       instantiatedType <- instantiateTyVarsToUnknown s (idType id)
-       return$ setIdType id instantiatedType
+        ticks = arr ! line
+
+        -- the ticks that span this coordinate
+        contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+
+leftmost  (_,a) (_,b) = a `compare` b
+rightmost (_,a) (_,b) = b `compare` a
+
+spans :: SrcSpan -> (Int,Int) -> Bool
+spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
+   where loc = mkSrcLoc (srcSpanFile span) l c
+
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: Module -> GHCi TickArray
+getTickArray modl = do
+   st <- getGHCiState
+   let arrmap = tickarrays st
+   case lookupModuleEnv arrmap modl of
+      Just arr -> return arr
+      Nothing  -> do
+        (breakArray, ticks) <- getModBreak modl 
+        let arr = mkTickArray (assocs ticks)
+        setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+        return arr
+
+discardTickArrays :: GHCi ()
+discardTickArrays = do
+   st <- getGHCiState
+   setGHCiState st{tickarrays = emptyModuleEnv}
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+  = accumArray (flip (:)) [] (1, max_line) 
+        [ (line, (nm,span)) | (nm,span) <- ticks,
+                              line <- srcSpanLines span ]
+    where
+        max_line = maximum (map srcSpanEndLine (map snd ticks))
+        srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+
+getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+getModBreak mod = do
+   session <- getSession
+   Just mod_info <- io $ GHC.getModuleInfo session mod
+   let modBreaks  = GHC.modInfoModBreaks mod_info
+   let array      = GHC.modBreaks_flags modBreaks
+   let ticks      = GHC.modBreaks_locs  modBreaks
+   return (array, ticks)
+
+lookupModule :: Session -> String -> GHCi Module
+lookupModule session modName
+   = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool 
+setBreakFlag toggle array index
+   | toggle    = setBreakOn array index 
+   | otherwise = setBreakOff array index
+
+
+{- these should probably go to the GHC API at some point -}
+enableBreakPoint  :: Session -> Module -> Int -> IO ()
+enableBreakPoint session mod index = return ()
+
+disableBreakPoint :: Session -> Module -> Int -> IO ()
+disableBreakPoint session mod index = return ()
+
+activeBreakPoints :: Session -> IO [(Module,Int)]
+activeBreakPoints session = return []
 
+enableSingleStep  :: Session -> IO ()
+enableSingleStep session = return ()
 
+disableSingleStep :: Session -> IO ()
+disableSingleStep session = return ()