Remove skolem tyvars from the InteractiveContext once they have been instantiated...

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 8066aa4..8f22af8 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -15,13 +15,13 @@ module InteractiveUI (
 
 import GhciMonad
 import GhciTags
 
 import GhciMonad
 import GhciTags

+import Debugger

 
 -- The GHC interface
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Type, Module, ModuleName, TyThing(..), Phase,
                           BreakIndex, Name, SrcSpan )
 
 -- The GHC interface
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Type, Module, ModuleName, TyThing(..), Phase,
                           BreakIndex, Name, SrcSpan )

-import Debugger

 import DynFlags
 import Packages
 import PackageConfig
 import DynFlags
 import Packages
 import PackageConfig

@@ -39,6 +39,7 @@ import Config
 import StaticFlags
 import Linker
 import Util
 import StaticFlags
 import Linker
 import Util

+import FastString

 
 #ifndef mingw32_HOST_OS
 import System.Posix
 
 #ifndef mingw32_HOST_OS
 import System.Posix

@@ -88,9 +89,9 @@ import System.Posix.Internals ( setNonBlockingFD )
 ghciWelcomeMsg =
  "   ___         ___ _\n"++
  "  / _ \\ /\\  /\\/ __(_)\n"++
 ghciWelcomeMsg =
  "   ___         ___ _\n"++
  "  / _ \\ /\\  /\\/ __(_)\n"++

- " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
+ " / /_\\// /_/ / /  | |    GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
+ "/ /_\\\\/ __  / /___| |    http://www.haskell.org/ghc/\n"++
+ "\\____/\\/ /_/\\____/|_|    Type :? for help.\n"

 
 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 cmdName (n,_,_,_) = n
 
 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 cmdName (n,_,_,_) = n

@@ -102,6 +103,7 @@ 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),

+  ("abandon",   keepGoing abandonCmd,           False, completeNone),

   ("break",     keepGoing breakCmd,             False, completeIdentifier),
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("break",     keepGoing breakCmd,             False, completeIdentifier),
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),

@@ -113,7 +115,7 @@ builtin_commands = [
   ("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),

-  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+  ("force",     keepGoing forceCmd,             False, completeIdentifier),

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

@@ -121,12 +123,12 @@ builtin_commands = [
   ("list",     keepGoing listCmd,              False, completeNone),
   ("module",   keepGoing setContext,           False, completeModule),
   ("main",     keepGoing runMain,              False, completeIdentifier),
   ("list",     keepGoing listCmd,              False, completeNone),
   ("module",   keepGoing setContext,           False, completeModule),
   ("main",     keepGoing runMain,              False, completeIdentifier),

-  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+  ("print",     keepGoing printCmd,             False, completeIdentifier),

   ("quit",     quit,                           False, completeNone),
   ("reload",   keepGoing reloadModule,         False, completeNone),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("quit",     quit,                           False, completeNone),
   ("reload",   keepGoing reloadModule,         False, completeNone),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),

-  ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+  ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),

   ("step",      stepCmd,                        False, completeIdentifier), 
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("step",      stepCmd,                        False, completeIdentifier), 
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,       False, completeMacro),

@@ -146,6 +148,7 @@ helpText =
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\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" ++
  "   :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" ++

@@ -448,9 +451,9 @@ mkPrompt toplevs exports resumes prompt
         f [] = empty
     
         perc_s
         f [] = empty
     
         perc_s

-          | (span,_,_):rest <- resumes 
+          | eval:rest <- resumes 

           = (if not (null rest) then text "... " else empty)
           = (if not (null rest) then text "... " else empty)

-            <> brackets (ppr span) <+> modules_prompt
+            <> brackets (ppr (evalSpan eval)) <+> modules_prompt

           | otherwise
           = modules_prompt
 
           | otherwise
           = modules_prompt
 

@@ -518,13 +521,13 @@ runStmt stmt
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $
                     GHC.runStmt session stmt
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $
                     GHC.runStmt session stmt

-      switchOnRunResult result
+      switchOnRunResult stmt 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
+switchOnRunResult :: String -> GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
+switchOnRunResult stmt GHC.RunFailed = return Nothing
+switchOnRunResult stmt (GHC.RunException e) = throw e
+switchOnRunResult stmt (GHC.RunOk names) = return $ Just (False,names)
+switchOnRunResult stmt (GHC.RunBreak threadId names info resume) = do

    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info) 
    let modBreaks  = GHC.modInfoModBreaks mod_info
    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info) 
    let modBreaks  = GHC.modInfoModBreaks mod_info

@@ -534,7 +537,10 @@ switchOnRunResult (GHC.RunBreak threadId names info resume) = do
    let location = ticks ! GHC.breakInfo_number info
    printForUser $ ptext SLIT("Stopped at") <+> ppr location
 
    let location = ticks ! GHC.breakInfo_number info
    printForUser $ ptext SLIT("Stopped at") <+> ppr location
 

-   pushResume location threadId resume
+   pushResume EvalInProgress{ evalStmt = stmt,
+                              evalSpan = location,
+                              evalThreadId = threadId,
+                              evalResumeHandle = resume }

 
    -- run the command set with ":set stop <cmd>"
    st <- getGHCiState
 
    -- run the command set with ":set stop <cmd>"
    st <- getGHCiState

@@ -1147,9 +1153,11 @@ showBkptTable = do
 showContext :: GHCi ()
 showContext = do
    st <- getGHCiState
 showContext :: GHCi ()
 showContext = do
    st <- getGHCiState

-   printForUser $ vcat (map pp_resume (resume st))
+   printForUser $ vcat (map pp_resume (reverse (resume st)))

   where
   where

-   pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
+   pp_resume eval =
+        ptext SLIT("--> ") <> text (evalStmt eval)
+        $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (evalSpan eval))

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

@@ -1354,6 +1362,14 @@ setUpConsole = do
 -- -----------------------------------------------------------------------------
 -- commands for debugger
 
 -- -----------------------------------------------------------------------------
 -- commands for debugger
 

+sprintCmd = pprintCommand False False
+printCmd  = pprintCommand True False
+forceCmd  = pprintCommand False True
+
+pprintCommand bind force str = do
+  session <- getSession
+  io $ pprintClosureCommand session bind force str
+

 foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
 
 stepCmd :: String -> GHCi Bool
 foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
 
 stepCmd :: String -> GHCi Bool

@@ -1375,14 +1391,24 @@ doContinue actionBeforeCont = do
       Nothing -> do 
          io $ putStrLn "There is no computation running."
          return False
       Nothing -> do 
          io $ putStrLn "There is no computation running."
          return False

-      Just (_,_,handle) -> do
+      Just eval -> do

          io $ actionBeforeCont
          session <- getSession
          io $ actionBeforeCont
          session <- getSession

-         runResult <- io $ GHC.resume session handle
-         names <- switchOnRunResult runResult
+         runResult <- io $ GHC.resume session (evalResumeHandle eval)
+         names <- switchOnRunResult (evalStmt eval) runResult

          finishEvalExpr names
          return False
 
          finishEvalExpr names
          return False
 

+abandonCmd :: String -> GHCi ()
+abandonCmd "" = do
+   mb_res <- popResume
+   case mb_res of
+      Nothing -> do 
+         io $ putStrLn "There is no computation running."
+      Just eval ->
+         return ()
+         -- the prompt will change to indicate the new context
+

 deleteCmd :: String -> GHCi ()
 deleteCmd argLine = do
    deleteSwitch $ words argLine
 deleteCmd :: String -> GHCi ()
 deleteCmd argLine = do
    deleteSwitch $ words argLine

@@ -1434,7 +1460,8 @@ breakSwitch session args@(arg1:rest)
                else do
             if GHC.isGoodSrcLoc loc
                then findBreakAndSet (GHC.nameModule n) $ 
                else do
             if GHC.isGoodSrcLoc loc
                then findBreakAndSet (GHC.nameModule n) $ 

-                         findBreakByCoord (GHC.srcLocLine loc, 
+                         findBreakByCoord (Just (GHC.srcLocFile loc))
+                                          (GHC.srcLocLine loc, 

                                            GHC.srcLocCol loc)
                else noCanDo $ text "can't find its location: " <>
                               ppr loc
                                            GHC.srcLocCol loc)
                else noCanDo $ text "can't find its location: " <>
                               ppr loc

@@ -1461,7 +1488,7 @@ breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
 breakByModuleLine mod line args
    | [] <- args = findBreakAndSet mod $ findBreakByLine line
    | [col] <- args, all isDigit col =
 breakByModuleLine mod line args
    | [] <- args = findBreakAndSet mod $ findBreakByLine line
    | [col] <- args, all isDigit col =

-        findBreakAndSet mod $ findBreakByCoord (line, read col)
+        findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)

    | otherwise = io $ putStrLn "Invalid arguments to :break"
 
 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
    | otherwise = io $ putStrLn "Invalid arguments to :break"
 
 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()

@@ -1512,8 +1539,9 @@ findBreakByLine line arr
         (complete,incomplete) = partition ends_here starts_here
             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
 
         (complete,incomplete) = partition ends_here starts_here
             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
 

-findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
-findBreakByCoord (line, col) arr
+findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
+                 -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord mb_file (line, col) arr

   | not (inRange (bounds arr) line) = Nothing
   | otherwise =
     listToMaybe (sortBy rightmost contains)
   | not (inRange (bounds arr) line) = Nothing
   | otherwise =
     listToMaybe (sortBy rightmost contains)

@@ -1521,7 +1549,13 @@ findBreakByCoord (line, col) arr
         ticks = arr ! line
 
         -- the ticks that span this coordinate
         ticks = arr ! line
 
         -- the ticks that span this coordinate

-        contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+        contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
+                            is_correct_file span ]
+
+        is_correct_file span
+                 | Just f <- mb_file = GHC.srcSpanFile span == f
+                 | otherwise         = True
+

 
 leftmost_smallest  (_,a) (_,b) = a `compare` b
 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
 
 leftmost_smallest  (_,a) (_,b) = a `compare` b
 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)

@@ -1541,7 +1575,7 @@ listCmd str = do
    st <- getGHCiState
    case resume st of
       []  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
    st <- getGHCiState
    case resume st of
       []  -> printForUser $ text "not stopped at a breakpoint; nothing to list"

-      (span,_,_):_ -> io $ listAround span True
+      eval:_ -> io $ listAround (evalSpan eval) True

 
 -- | list a section of a source file around a particular SrcSpan.
 -- If the highlight flag is True, also highlight the span using
 
 -- | list a section of a source file around a particular SrcSpan.
 -- If the highlight flag is True, also highlight the span using