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 dddbb34..fd84f9d 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -10,7 +10,7 @@
 -- 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/CodingStyle#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
@@ -76,6 +76,7 @@ import System.Exit    ( exitWith, ExitCode(..) )
 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
@@ -1345,10 +1346,11 @@ completeNone w = return []
 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
-       | 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
@@ -1357,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'
+        | ("import" : _) <- line_words ->
+                wrapCompleter completeModule w
        | otherwise     -> do
                --printf "complete %s, start = %d, end = %d\n" w start end
                wrapCompleter completeIdentifier w
@@ -1372,9 +1376,6 @@ completeWord w start end = do
               | 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
@@ -1817,18 +1818,18 @@ findBreakByCoord mb_file (line, col) arr
                               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 :: String
 start_bold = "\ESC[1m"
+end_bold :: String
 end_bold   = "\ESC[0m"
 
 listCmd :: String -> GHCi ()
@@ -1895,10 +1896,10 @@ listAround span do_highlight = do
           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 ]
-          prefixed = zipWith BS.append bs_line_nos highlighted
+          prefixed = zipWith ($) highlighted bs_line_nos
       --
       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
   where
@@ -1915,32 +1916,33 @@ listAround span do_highlight = do
         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
-            BS.concat [a,BS.pack start_bold,b,BS.pack 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
-            BS.concat [a, BS.pack start_bold, b]
+            BS.concat [prefix, a, BS.pack start_bold, b]
           | no == line2
           = let (a,b) = BS.splitAt col2 line in
-            BS.concat [a, BS.pack 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
-          = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+          = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
                                          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
-          = 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
-           indent = BS.pack "   "
+           indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
            nl = BS.singleton '\n'
 
 -- --------------------------------------------------------------------------