FIX #1466 (partly), which was causing concprog001(ghci) to fail

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 22b8211..fd84f9d 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -6,6 +6,13 @@
 -- (c) The GHC Team 2005-2006
 --
 -----------------------------------------------------------------------------
 -- (c) The GHC Team 2005-2006
 --
 -----------------------------------------------------------------------------

+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+

 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
 
 #include "HsVersions.h"
 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
 
 #include "HsVersions.h"

@@ -69,6 +76,7 @@ import System.Exit    ( exitWith, ExitCode(..) )
 import System.Directory
 import System.IO
 import System.IO.Error as IO
 import System.Directory
 import System.IO
 import System.IO.Error as IO

+import System.IO.Unsafe

 import Data.Char
 import Data.Dynamic
 import Data.Array
 import Data.Char
 import Data.Dynamic
 import Data.Array

@@ -130,7 +138,8 @@ builtin_commands = [
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
   ("step",      keepGoing stepCmd,              False, completeIdentifier), 
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
   ("step",      keepGoing stepCmd,              False, completeIdentifier), 

-  ("stepover",  keepGoing stepOverCmd,          False, completeIdentifier), 
+  ("steplocal", keepGoing stepLocalCmd,         False, completeIdentifier), 
+  ("stepmodule",keepGoing stepModuleCmd,        False, completeIdentifier), 

   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("trace",     keepGoing traceCmd,             False, completeIdentifier), 
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("trace",     keepGoing traceCmd,             False, completeIdentifier), 
   ("undef",     keepGoing undefineMacro,       False, completeMacro),

@@ -186,6 +195,8 @@ helpText =
  "   :sprint [<name> ...]        simplifed version of :print\n" ++
  "   :step                       single-step after stopping at a breakpoint\n"++
  "   :step <expr>                single-step into <expr>\n"++
  "   :sprint [<name> ...]        simplifed version of :print\n" ++
  "   :step                       single-step after stopping at a breakpoint\n"++
  "   :step <expr>                single-step into <expr>\n"++

+ "   :steplocal                  single-step restricted to the current top level decl.\n"++
+ "   :stepmodule                 single-step restricted to the current module\n"++

  "   :trace                      trace after stopping at a breakpoint\n"++
  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 
  "   :trace                      trace after stopping at a breakpoint\n"++
  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 

@@ -464,7 +475,7 @@ mkPrompt = do
                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
                    else do
                         let hist = GHC.resumeHistory r !! (ix-1)
                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
                    else do
                         let hist = GHC.resumeHistory r !! (ix-1)

-                        span <- io $ GHC.getHistorySpan session hist
+                        span <- io$ GHC.getHistorySpan session hist

                         return (brackets (ppr (negate ix) <> char ':' 
                                           <+> ppr span) <> space)
   let
                         return (brackets (ppr (negate ix) <> char ':' 
                                           <+> ppr span) <> space)
   let

@@ -565,7 +576,7 @@ runStmt stmt step
 --afterRunStmt :: GHC.RunResult -> GHCi Bool
                                  -- False <=> the statement failed to compile
 afterRunStmt _ (GHC.RunException e) = throw e
 --afterRunStmt :: GHC.RunResult -> GHCi Bool
                                  -- False <=> the statement failed to compile
 afterRunStmt _ (GHC.RunException e) = throw e

-afterRunStmt pred run_result = do
+afterRunStmt step_here run_result = do

   session     <- getSession
   resumes <- io $ GHC.getResumeContext session
   case run_result of
   session     <- getSession
   resumes <- io $ GHC.getResumeContext session
   case run_result of

@@ -574,17 +585,18 @@ afterRunStmt pred run_result = do
         when show_types $ printTypeOfNames session names
      GHC.RunBreak _ names mb_info 
          | isNothing  mb_info || 
         when show_types $ printTypeOfNames session names
      GHC.RunBreak _ names mb_info 
          | isNothing  mb_info || 

-           pred (GHC.resumeSpan $ head resumes) -> do
+           step_here (GHC.resumeSpan $ head resumes) -> do

                printForUser $ ptext SLIT("Stopped at") <+> 
                        ppr (GHC.resumeSpan $ head resumes)
                printForUser $ ptext SLIT("Stopped at") <+> 
                        ppr (GHC.resumeSpan $ head resumes)

-               printTypeOfNames session names
+--               printTypeOfNames session names
+               printTypeAndContentOfNames session names

                maybe (return ()) runBreakCmd mb_info
                -- run the command set with ":set stop <cmd>"
                st <- getGHCiState
                enqueueCommands [stop st]
                return ()
          | otherwise -> io(GHC.resume session GHC.SingleStep) >>= 
                maybe (return ()) runBreakCmd mb_info
                -- run the command set with ":set stop <cmd>"
                st <- getGHCiState
                enqueueCommands [stop st]
                return ()
          | otherwise -> io(GHC.resume session GHC.SingleStep) >>= 

-                        afterRunStmt pred >> return ()
+                        afterRunStmt step_here >> return ()

      _ -> return ()
 
   flushInterpBuffers
      _ -> return ()
 
   flushInterpBuffers

@@ -594,6 +606,18 @@ afterRunStmt pred run_result = do
 
   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 
 
   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 

+      where printTypeAndContentOfNames session names = do
+              let namesSorted = sortBy compareNames names
+              tythings <- catMaybes `liftM` 
+                              io (mapM (GHC.lookupName session) namesSorted)
+              docs_ty  <- mapM showTyThing tythings
+              terms    <- mapM (io . GHC.obtainTermB session 10 False)
+                               [ id | (AnId id, Just _) <- zip tythings docs_ty]
+              docs_terms <- mapM (io . showTerm session) terms                                   
+              printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
+                                            (catMaybes docs_ty)
+                                            docs_terms
+

 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 runBreakCmd info = do
   let mod = GHC.breakInfo_module info
 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 runBreakCmd info = do
   let mod = GHC.breakInfo_module info

@@ -666,7 +690,7 @@ getCurrentBreakModule = do
     (r:rs) -> do
         let ix = GHC.resumeHistoryIx r
         if ix == 0
     (r:rs) -> do
         let ix = GHC.resumeHistoryIx r
         if ix == 0

-           then return (GHC.breakInfo_module `fmap` GHC.resumeBreakInfo r)
+           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)

            else do
                 let hist = GHC.resumeHistory r !! (ix-1)
                 return $ Just $ GHC.getHistoryModule  hist
            else do
                 let hist = GHC.resumeHistory r !! (ix-1)
                 return $ Just $ GHC.getHistoryModule  hist

@@ -892,8 +916,6 @@ checkModule m = do
 
 reloadModule :: String -> GHCi ()
 reloadModule m = do
 
 reloadModule :: String -> GHCi ()
 reloadModule m = do

-  io (revertCAFs)              -- always revert CAFs on reload.
-  discardActiveBreakPoints

   session <- getSession
   doLoad session $ if null m then LoadAllTargets 
                              else LoadUpTo (GHC.mkModuleName m)
   session <- getSession
   doLoad session $ if null m then LoadAllTargets 
                              else LoadUpTo (GHC.mkModuleName m)

@@ -1277,11 +1299,18 @@ showBindings = do
 compareTyThings :: TyThing -> TyThing -> Ordering
 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
 
 compareTyThings :: TyThing -> TyThing -> Ordering
 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
 

-printTyThing :: TyThing -> GHCi ()
-printTyThing (AnId id) = do
+showTyThing :: TyThing -> GHCi (Maybe SDoc)
+showTyThing (AnId id) = do

   ty' <- cleanType (GHC.idType id)
   ty' <- cleanType (GHC.idType id)

-  printForUser $ ppr id <> text " :: " <> ppr ty'
-printTyThing _ = return ()
+  return $ Just $ ppr id <> text " :: " <> ppr ty'
+showTyThing _ = return Nothing
+
+printTyThing :: TyThing -> GHCi ()
+printTyThing tyth = do
+  mb_x <- showTyThing tyth
+  case mb_x of
+    Just x  -> printForUser x
+    Nothing -> return ()

 
 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
 cleanType :: Type -> GHCi Type
 
 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
 cleanType :: Type -> GHCi Type

@@ -1317,10 +1346,11 @@ completeNone w = return []
 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
 completeWord w start end = do
   line <- Readline.getLineBuffer
 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
 completeWord w start end = do
   line <- Readline.getLineBuffer

-  case w of 
+  let line_words = words (dropWhile isSpace line)
+  case w of

      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
      _other
      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
      _other

-       | Just c <- is_cmd line -> do
+       | ((':':c) : _) <- line_words -> do

           maybe_cmd <- lookupCommand c
            let (n,w') = selectWord (words' 0 line)
           case maybe_cmd of
           maybe_cmd <- lookupCommand c
            let (n,w') = selectWord (words' 0 line)
           case maybe_cmd of

@@ -1329,6 +1359,8 @@ completeWord w start end = do
             Just (_,_,True,complete) -> let complete' w = do rets <- complete w
                                                               return (map (drop n) rets)
                                          in wrapCompleter complete' w'
             Just (_,_,True,complete) -> let complete' w = do rets <- complete w
                                                               return (map (drop n) rets)
                                          in wrapCompleter complete' w'

+        | ("import" : _) <- line_words ->
+                wrapCompleter completeModule w

        | otherwise     -> do
                --printf "complete %s, start = %d, end = %d\n" w start end
                wrapCompleter completeIdentifier w
        | otherwise     -> do
                --printf "complete %s, start = %d, end = %d\n" w start end
                wrapCompleter completeIdentifier w

@@ -1344,9 +1376,6 @@ completeWord w start end = do
               | offset+length x >= start = (start-offset,take (end-offset) x)
               | otherwise = selectWord xs
 
               | offset+length x >= start = (start-offset,take (end-offset) x)
               | otherwise = selectWord xs
 

-is_cmd line 
- | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
- | otherwise = Nothing

 
 completeCmd w = do
   cmds <- readIORef commands
 
 completeCmd w = do
   cmds <- readIORef commands

@@ -1548,43 +1577,31 @@ stepCmd :: String -> GHCi ()
 stepCmd []         = doContinue (const True) GHC.SingleStep
 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
 
 stepCmd []         = doContinue (const True) GHC.SingleStep
 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
 

-stepOverCmd [] = do 
+stepLocalCmd :: String -> GHCi ()
+stepLocalCmd  [] = do 

   mb_span <- getCurrentBreakSpan
   case mb_span of
     Nothing  -> stepCmd []
     Just loc -> do
        Just mod <- getCurrentBreakModule
   mb_span <- getCurrentBreakSpan
   case mb_span of
     Nothing  -> stepCmd []
     Just loc -> do
        Just mod <- getCurrentBreakModule

-       parent   <- enclosingTickSpan mod loc
-       allTicksRightmost <- (sortBy rightmost . map snd) `fmap` 
-                               ticksIn mod parent
-       let lastTick = null allTicksRightmost || 
-                      head allTicksRightmost == loc
-       if not lastTick
-              then doContinue (`isSubspanOf` parent) GHC.SingleStep
-              else doContinue (const True) GHC.SingleStep
-
-    where 
-
-{- 
- So, the only tricky part in stepOver is detecting that we have 
- arrived to the last tick in an expression, in which case we must
- step normally to the next tick.
- What we do is:
-  1. Retrieve the enclosing expression block (with a tick)
-  2. Retrieve all the ticks there and sort them out by 'rightness'
-  3. See if the current tick turned out the first one in the list
--}
-
---ticksIn :: Module -> SrcSpan -> GHCi [Tick]
-ticksIn mod src = do
-  ticks <- getTickArray mod
-  let lines = [srcSpanStartLine src .. srcSpanEndLine src]
-  return [  t   | line <- lines
-                , t@(_,span) <- ticks ! line
-                , srcSpanStart src <= srcSpanStart span
-                , srcSpanEnd src   >= srcSpanEnd span
-                ]
+       current_toplevel_decl <- enclosingTickSpan mod loc
+       doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
+
+stepLocalCmd expression = stepCmd expression

 
 

+stepModuleCmd :: String -> GHCi ()
+stepModuleCmd  [] = do 
+  mb_span <- getCurrentBreakSpan
+  case mb_span of
+    Nothing  -> stepCmd []
+    Just loc -> do
+       Just span <- getCurrentBreakSpan
+       let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
+       doContinue f GHC.SingleStep
+
+stepModuleCmd expression = stepCmd expression
+
+-- | Returns the span of the largest tick containing the srcspan given

 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
 enclosingTickSpan mod src = do
   ticks <- getTickArray mod
 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
 enclosingTickSpan mod src = do
   ticks <- getTickArray mod

@@ -1647,10 +1664,18 @@ historyCmd arg
         let hist = GHC.resumeHistory r
             (took,rest) = splitAt num hist
         spans <- mapM (io . GHC.getHistorySpan s) took
         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)))
+        let nums  = map (printf "-%-3d:") [(1::Int)..]
+        let names = map GHC.historyEnclosingDecl took
+        printForUser (vcat(zipWith3 
+                             (\x y z -> x <+> y <+> z) 
+                             (map text nums) 
+                             (map (bold . ppr) names)
+                             (map (parens . ppr) spans)))

         io $ putStrLn $ if null rest then "<end of history>" else "..."
 
         io $ putStrLn $ if null rest then "<end of history>" else "..."
 

+bold c | do_bold   = text start_bold <> c <> text end_bold
+       | otherwise = c
+

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

@@ -1793,19 +1818,19 @@ findBreakByCoord mb_file (line, col) arr
                               GHC.srcSpanStartLine span == line,
                               GHC.srcSpanStartCol span >= col ]
 
                               GHC.srcSpanStartLine span == line,
                               GHC.srcSpanStartCol span >= col ]
 

--- for now, use ANSI bold on Unixy systems.  On Windows, we add a line
--- of carets under the active expression instead.  The Windows console
--- doesn't support ANSI escape sequences, and most Unix terminals
--- (including xterm) do, so this is a reasonable guess until we have a
--- proper termcap/terminfo library.
-#if !defined(mingw32_TARGET_OS)
-do_bold = True
-#else
-do_bold = False
-#endif
+-- For now, use ANSI bold on terminals that we know support it.
+-- Otherwise, we add a line of carets under the active expression instead.
+-- In particular, on Windows and when running the testsuite (which sets
+-- TERM to vt100 for other reasons) we get carets.
+-- We really ought to use a proper termcap/terminfo library.
+do_bold :: Bool
+do_bold = unsafePerformIO (System.Environment.getEnv "TERM") `elem`
+          ["xterm", "linux"]

 
 

-start_bold = BS.pack "\ESC[1m"
-end_bold   = BS.pack "\ESC[0m"
+start_bold :: String
+start_bold = "\ESC[1m"
+end_bold :: String
+end_bold   = "\ESC[0m"

 
 listCmd :: String -> GHCi ()
 listCmd "" = do
 
 listCmd :: String -> GHCi ()
 listCmd "" = do

@@ -1871,10 +1896,10 @@ listAround span do_highlight = do
           line_nos = [ fst_line .. ]
 
           highlighted | do_highlight = zipWith highlight line_nos these_lines
           line_nos = [ fst_line .. ]
 
           highlighted | do_highlight = zipWith highlight line_nos these_lines

-                      | otherwise   = these_lines
+                      | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]

 
           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
 
           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]

-          prefixed = zipWith BS.append bs_line_nos highlighted
+          prefixed = zipWith ($) highlighted bs_line_nos

       --
       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
   where
       --
       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
   where

@@ -1891,32 +1916,33 @@ listAround span do_highlight = do
         highlight | do_bold   = highlight_bold
                   | otherwise = highlight_carets
 
         highlight | do_bold   = highlight_bold
                   | otherwise = highlight_carets
 

-        highlight_bold no line
+        highlight_bold no line prefix

           | no == line1 && no == line2
           = let (a,r) = BS.splitAt col1 line
                 (b,c) = BS.splitAt (col2-col1) r
             in
           | no == line1 && no == line2
           = let (a,r) = BS.splitAt col1 line
                 (b,c) = BS.splitAt (col2-col1) r
             in

-            BS.concat [a,start_bold,b,end_bold,c]
+            BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]

           | no == line1
           = let (a,b) = BS.splitAt col1 line in
           | no == line1
           = let (a,b) = BS.splitAt col1 line in

-            BS.concat [a, start_bold, b]
+            BS.concat [prefix, a, BS.pack start_bold, b]

           | no == line2
           = let (a,b) = BS.splitAt col2 line in
           | no == line2
           = let (a,b) = BS.splitAt col2 line in

-            BS.concat [a, end_bold, b]
-          | otherwise   = line
+            BS.concat [prefix, a, BS.pack end_bold, b]
+          | otherwise   = BS.concat [prefix, line]

 
 

-        highlight_carets no line
+        highlight_carets no line prefix

           | no == line1 && no == line2
           | no == line1 && no == line2

-          = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+          = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',

                                          BS.replicate (col2-col1) '^']
           | no == line1
                                          BS.replicate (col2-col1) '^']
           | no == line1

-          = BS.concat [line, nl, indent, BS.replicate col1 ' ',
-                                         BS.replicate (BS.length line-col1) '^']
+          = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, 
+                                         prefix, line]

           | no == line2
           | no == line2

-          = BS.concat [line, nl, indent, BS.replicate col2 '^']
-          | otherwise   = line
+          = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
+                                         BS.pack "^^"]
+          | otherwise   = BS.concat [prefix, line]

          where
          where

-           indent = BS.pack "   "
+           indent = BS.pack ("  " ++ replicate (length (show no)) ' ')

            nl = BS.singleton '\n'
 
 -- --------------------------------------------------------------------------
            nl = BS.singleton '\n'
 
 -- --------------------------------------------------------------------------