X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=059d692df697d59c06b8580de739b2429cfe0438;hb=0b60725b6817a819b0d3c5ad940aef3eda008b88;hp=e0dd5cc17c28c7bb7d63f50b7321665bd22c52ad;hpb=766b34f81d81d009f1070e297756423fbadbd421;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index e0dd5cc..059d692 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -52,7 +52,7 @@ import StaticFlags
 import Linker
 import Util
 import NameSet
-import Maybes		( orElse )
+import Maybes		( orElse, expectJust )
 import FastString
 import Encoding
 import MonadUtils       ( liftIO )
@@ -85,7 +85,6 @@ import System.Directory
 import System.IO
 import System.IO.Error as IO
 import Data.Char
-import Data.Dynamic
 import Data.Array
 import Control.Monad as Monad
 import Text.Printf
@@ -97,10 +96,6 @@ import GHC.TopHandler
 
 import Data.IORef	( IORef, readIORef, writeIORef )
 
-#ifdef USE_EDITLINE
-import System.Posix.Internals ( setNonBlockingFD )
-#endif
-
 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg :: String
@@ -256,7 +251,7 @@ helpText =
  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
  "   :set editor <cmd>           set the command used for :edit\n" ++
- "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
+ "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" ++
  "   :unset <option> ...         unset options\n" ++
  "\n" ++
  "  Options for ':set' and ':unset':\n" ++
@@ -294,7 +289,7 @@ findEditor = do
 
 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
               -> Ghc ()
-interactiveUI srcs maybe_exprs = do
+interactiveUI srcs maybe_exprs = withTerminalReset $ do
    -- HACK! If we happen to get into an infinite loop (eg the user
    -- types 'let x=x in x' at the prompt), then the thread will block
    -- on a blackhole, and become unreachable during GC.  The GC will
@@ -383,6 +378,21 @@ withGhcAppData right left = do
       Right dir -> right dir
       _ -> left
 
+-- libedit doesn't always restore the terminal settings correctly (as of at 
+-- least 07/12/2008); see trac #2691.  Work around this by manually resetting
+-- the terminal outselves.
+withTerminalReset :: Ghc () -> Ghc ()
+#ifdef mingw32_HOST_OS
+withTerminalReset = id
+#else
+withTerminalReset f = do
+    isTTY <- liftIO $ hIsTerminalDevice stdout
+    if not isTTY
+        then f
+        else gbracket (liftIO $ getTerminalAttributes stdOutput)
+                (\attrs -> liftIO $ setTerminalAttributes stdOutput attrs Immediately)
+                (const f)
+#endif
 
 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
 runGHCi paths maybe_exprs = do
@@ -627,11 +637,8 @@ readlineLoop = do
                    return (Just str)
 
 withReadline :: IO a -> IO a
-withReadline = bracket_ stopTimer (do startTimer; setNonBlockingFD 0)
-     -- Two problems are being worked around here:
-     -- 1. readline sometimes puts stdin into blocking mode,
-     --    so we need to put it back for the IO library
-     -- 2. editline doesn't handle some of its system calls returning
+withReadline = bracket_ stopTimer startTimer
+     --    editline doesn't handle some of its system calls returning
      --    EINTR, so our timer signal confuses it, hence we turn off
      --    the timer signal when making calls to editline. (#2277)
      --    If editline is ever fixed, we can remove this.
@@ -667,7 +674,7 @@ runCommands' eh getCmd = do
   where
     printErrorAndKeepGoing err = do
         GHC.printExceptionAndWarnings err
-        return True
+        return False
 
     noSpace q = q >>= maybe (return Nothing)
                             (\c->case removeSpaces c of 
@@ -1088,7 +1095,8 @@ checkModule m = do
 	   case GHC.moduleInfo r of
 	     cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 		let
-		    (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
+		    (local,global) = ASSERT( all isExternalName scope )
+		    		     partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 		in
 			(text "global names: " <+> ppr global) $$
 		        (text "local  names: " <+> ppr local)
@@ -1275,7 +1283,8 @@ browseModule bang modl exports_only = do
                 -- We would like to improve this; see #1799.
             sorted_names = loc_sort local ++ occ_sort external
                 where 
-                (local,external) = partition ((==modl) . nameModule) names
+                (local,external) = ASSERT( all isExternalName names )
+				   partition ((==modl) . nameModule) names
                 occ_sort = sortBy (compare `on` nameOccName) 
                 -- try to sort by src location.  If the first name in
                 -- our list has a good source location, then they all should.
@@ -1483,10 +1492,13 @@ setPrompt value = do
   st <- getGHCiState
   if null value
       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
-      else setGHCiState st{ prompt = remQuotes value }
-  where
-     remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
-     remQuotes x = x
+      else case value of
+           '\"' : _ -> case reads value of
+                       [(value', xs)] | all isSpace xs ->
+                           setGHCiState (st { prompt = value' })
+                       _ ->
+                           io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
+           _ -> setGHCiState (st { prompt = value })
 
 setOptions wds =
    do -- first, deal with the GHCi opts (+s, +t, etc.)
@@ -1738,7 +1750,8 @@ completeHomeModule w = do
 
 completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)
-    where options = "args":"prog":allFlags
+    where options = "args":"prog":flagList
+          flagList = map head $ group $ sort allFlags
 
 completeFilename w = do
     ws <- Readline.filenameCompletionFunction w
@@ -1818,28 +1831,15 @@ handler exception = do
   ghciHandle handler (showException exception >> return False)
 
 showException :: SomeException -> GHCi ()
-#if __GLASGOW_HASKELL__ < 609
-showException (DynException dyn) =
-  case fromDynamic dyn of
-    Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
-    Just Interrupted      -> io (putStrLn "Interrupted.")
-    Just (CmdLineError s) -> io (putStrLn s)	 -- omit the location for CmdLineError
-    Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
-    Just other_ghc_ex     -> io (print other_ghc_ex)
-
-showException other_exception
-  = io (putStrLn ("*** Exception: " ++ show other_exception))
-#else
-showException (SomeException e) =
-  io $ case cast e of
+showException se =
+  io $ case fromException se of
        Just Interrupted         -> putStrLn "Interrupted."
        -- omit the location for CmdLineError:
        Just (CmdLineError s)    -> putStrLn s
        -- ditto:
        Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
        Just other_ghc_ex        -> print other_ghc_ex
-       Nothing                  -> putStrLn ("*** Exception: " ++ show e)
-#endif
+       Nothing                  -> putStrLn ("*** Exception: " ++ show se)
 
 -----------------------------------------------------------------------------
 -- recursive exception handlers
@@ -1896,7 +1896,7 @@ wantNameFromInterpretedModule noCanDo str and_then =
    case names of
       []    -> return ()
       (n:_) -> do
-            let modl = GHC.nameModule n
+            let modl = ASSERT( isExternalName n ) GHC.nameModule n
             if not (GHC.isExternalName n)
                then noCanDo n $ ppr n <>
                                 text " is not defined in an interpreted module"
@@ -2068,7 +2068,8 @@ breakSwitch (arg1:rest)
         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
         if GHC.isGoodSrcLoc loc
-               then findBreakAndSet (GHC.nameModule name) $ 
+               then ASSERT( isExternalName name ) 
+	       	    findBreakAndSet (GHC.nameModule name) $ 
                          findBreakByCoord (Just (GHC.srcLocFile loc))
                                           (GHC.srcLocLine loc, 
                                            GHC.srcLocCol loc)
@@ -2215,7 +2216,8 @@ list2 [arg] = do
         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
         if GHC.isGoodSrcLoc loc
                then do
-                  tickArray <- getTickArray (GHC.nameModule name)
+                  tickArray <- ASSERT( isExternalName name )
+		  	       getTickArray (GHC.nameModule name)
                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
                                         tickArray
@@ -2238,7 +2240,7 @@ listModuleLine modl line = do
    case this of
      [] -> panic "listModuleLine"
      summ:_ -> do
-           let filename = fromJust (ml_hs_file (GHC.ms_location summ))
+           let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
            io $ listAround (GHC.srcLocSpan loc) False