Force the result of user-defined commands

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index a16a5b9..8a70787 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -34,7 +34,8 @@ import PackageConfig
 import UniqFM
 #endif
 
 import UniqFM
 #endif
 

-import HscTypes                ( implicitTyThings, reflectGhc, reifyGhc )
+import HscTypes                ( implicitTyThings, reflectGhc, reifyGhc
+                        , handleFlagWarnings )

 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
 import Outputable       hiding (printForUser, printForUserPartWay)
 import Module           -- for ModuleEnv
 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
 import Outputable       hiding (printForUser, printForUserPartWay)
 import Module           -- for ModuleEnv

@@ -42,7 +43,6 @@ import Name
 import SrcLoc
 
 -- Other random utilities
 import SrcLoc
 
 -- Other random utilities

-import ErrUtils

 import CmdLineParser
 import Digraph
 import BasicTypes hiding (isTopLevel)
 import CmdLineParser
 import Digraph
 import BasicTypes hiding (isTopLevel)

@@ -52,7 +52,7 @@ import StaticFlags
 import Linker
 import Util
 import NameSet
 import Linker
 import Util
 import NameSet

-import Maybes          ( orElse )
+import Maybes          ( orElse, expectJust )

 import FastString
 import Encoding
 import MonadUtils       ( liftIO )
 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 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
 import Data.Array
 import Control.Monad as Monad
 import Text.Printf

@@ -97,10 +96,6 @@ import GHC.TopHandler
 
 import Data.IORef      ( IORef, readIORef, writeIORef )
 
 
 import Data.IORef      ( IORef, readIORef, writeIORef )
 

-#ifdef USE_EDITLINE
-import System.Posix.Internals ( setNonBlockingFD )
-#endif
-

 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg :: String
 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg :: String

@@ -148,7 +143,7 @@ builtin_commands = [
   ("reload",   keepGoing reloadModule,         Nothing, completeNone),
   ("run",      keepGoing runRun,               Nothing, completeIdentifier),
   ("set",      keepGoing setCmd,               Just flagWordBreakChars, completeSetOptions),
   ("reload",   keepGoing reloadModule,         Nothing, completeNone),
   ("run",      keepGoing runRun,               Nothing, completeIdentifier),
   ("set",      keepGoing setCmd,               Just flagWordBreakChars, completeSetOptions),

-  ("show",     keepGoing showCmd,              Nothing, completeNone),
+  ("show",     keepGoing showCmd,              Nothing, completeShowOptions),

   ("sprint",    keepGoing sprintCmd,            Nothing, completeIdentifier),
   ("step",      keepGoing stepCmd,              Nothing, completeIdentifier), 
   ("steplocal", keepGoing stepLocalCmd,         Nothing, completeIdentifier), 
   ("sprint",    keepGoing sprintCmd,            Nothing, completeIdentifier),
   ("step",      keepGoing stepCmd,              Nothing, completeIdentifier), 
   ("steplocal", keepGoing stepLocalCmd,         Nothing, completeIdentifier), 

@@ -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 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" ++
  "   :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 :: [(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
    -- 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

@@ -345,8 +340,6 @@ interactiveUI srcs maybe_exprs = do
 
    default_editor <- liftIO $ findEditor
 
 
    default_editor <- liftIO $ findEditor
 

-   cwd <- liftIO $ getCurrentDirectory
-

    startGHCi (runGHCi srcs maybe_exprs)
         GHCiState{ progname = "<interactive>",
                    args = [],
    startGHCi (runGHCi srcs maybe_exprs)
         GHCiState{ progname = "<interactive>",
                    args = [],

@@ -362,7 +355,6 @@ interactiveUI srcs maybe_exprs = do
                    last_command = Nothing,
                    cmdqueue = [],
                    remembered_ctx = [],
                    last_command = Nothing,
                    cmdqueue = [],
                    remembered_ctx = [],

-                   virtual_path   = cwd,

                    ghc_e = isJust maybe_exprs
                  }
 
                    ghc_e = isJust maybe_exprs
                  }
 

@@ -383,6 +375,21 @@ withGhcAppData right left = do
       Right dir -> right dir
       _ -> left
 
       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
 
 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
 runGHCi paths maybe_exprs = do

@@ -627,11 +634,8 @@ readlineLoop = do
                    return (Just str)
 
 withReadline :: IO a -> IO a
                    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.
      --    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 +671,7 @@ runCommands' eh getCmd = do
   where
     printErrorAndKeepGoing err = do
         GHC.printExceptionAndWarnings err
   where
     printErrorAndKeepGoing err = do
         GHC.printExceptionAndWarnings err

-        return True
+        return False

 
     noSpace q = q >>= maybe (return Nothing)
                             (\c->case removeSpaces c of 
 
     noSpace q = q >>= maybe (return Nothing)
                             (\c->case removeSpaces c of 

@@ -863,7 +867,8 @@ help _ = io (putStr helpText)
 
 info :: String -> GHCi ()
 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 
 info :: String -> GHCi ()
 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")

-info s  = do { let names = words s
+info s  = handleSourceError GHC.printExceptionAndWarnings $ do
+             { let names = words s

             ; dflags <- getDynFlags
             ; let pefas = dopt Opt_PrintExplicitForalls dflags
             ; mapM_ (infoThing pefas) names }
             ; dflags <- getDynFlags
             ; let pefas = dopt Opt_PrintExplicitForalls dflags
             ; mapM_ (infoThing pefas) names }

@@ -1025,6 +1030,9 @@ defineMacro overwrite s = do
 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 runMacro fun s = do
   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 runMacro fun s = do
   str <- io ((unsafeCoerce# fun :: String -> IO String) s)

+  -- make sure we force any exceptions in the result, while we are still
+  -- inside the exception handler for commands:
+  seqList str (return ())

   enqueueCommands (lines str)
   return False
 
   enqueueCommands (lines str)
   return False
 

@@ -1082,12 +1090,13 @@ checkModule m = do
   let modl = GHC.mkModuleName m
   prev_context <- GHC.getContext
   ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
   let modl = GHC.mkModuleName m
   prev_context <- GHC.getContext
   ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do

-          r <- GHC.typecheckModule =<< GHC.parseModule modl
+          r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl

           io $ putStrLn (showSDoc (
           case GHC.moduleInfo r of
             cm | Just scope <- GHC.modInfoTopLevelScope cm ->
                let
           io $ putStrLn (showSDoc (
           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)
                in
                        (text "global names: " <+> ppr global) $$
                        (text "local  names: " <+> ppr local)

@@ -1201,8 +1210,7 @@ typeOfExpr str
        ty <- GHC.exprType str
        dflags <- getDynFlags
        let pefas = dopt Opt_PrintExplicitForalls dflags
        ty <- GHC.exprType str
        dflags <- getDynFlags
        let pefas = dopt Opt_PrintExplicitForalls dflags

-       printForUser $ text str <+> dcolon
-                       <+> pprTypeForUser pefas ty
+       printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]

 
 kindOfType :: String -> GHCi ()
 kindOfType str 
 
 kindOfType :: String -> GHCi ()
 kindOfType str 

@@ -1274,7 +1282,8 @@ browseModule bang modl exports_only = do
                 -- We would like to improve this; see #1799.
             sorted_names = loc_sort local ++ occ_sort external
                 where 
                 -- 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.
                 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.

@@ -1482,10 +1491,13 @@ setPrompt value = do
   st <- getGHCiState
   if null value
       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
   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.)
 
 setOptions wds =
    do -- first, deal with the GHCi opts (+s, +t, etc.)

@@ -1499,7 +1511,7 @@ newDynFlags minus_opts = do
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
       (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
       (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts

-      io $ handleFlagWarnings dflags' warns
+      handleFlagWarnings dflags' warns

 
       if (not (null leftovers))
         then ghcError $ errorsToGhcException leftovers
 
       if (not (null leftovers))
         then ghcError $ errorsToGhcException leftovers

@@ -1662,8 +1674,8 @@ completeNone :: String -> IO [String]
 completeNone _w = return []
 
 completeMacro, completeIdentifier, completeModule,
 completeNone _w = return []
 
 completeMacro, completeIdentifier, completeModule,

-    completeHomeModule, completeSetOptions, completeFilename,
-    completeHomeModuleOrFile 
+    completeHomeModule, completeSetOptions, completeShowOptions,
+    completeFilename, completeHomeModuleOrFile

     :: String -> IO [String]
 
 #ifdef USE_EDITLINE
     :: String -> IO [String]
 
 #ifdef USE_EDITLINE

@@ -1737,7 +1749,14 @@ completeHomeModule w = do
 
 completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)
 
 completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)

-    where options = "args":"prog":allFlags
+    where options = "args":"prog":"prompt":"editor":"stop":flagList
+          flagList = map head $ group $ sort allFlags
+
+completeShowOptions w = do
+  return (filter (w `isPrefixOf`) options)
+    where options = ["args", "prog", "prompt", "editor", "stop",
+                     "modules", "bindings", "linker", "breaks",
+                     "context", "packages", "languages"]

 
 completeFilename w = do
     ws <- Readline.filenameCompletionFunction w
 
 completeFilename w = do
     ws <- Readline.filenameCompletionFunction w

@@ -1787,12 +1806,13 @@ allExposedModules dflags
  where
   pkg_db = pkgIdMap (pkgState dflags)
 #else
  where
   pkg_db = pkgIdMap (pkgState dflags)
 #else

-completeMacro      = completeNone
-completeIdentifier = completeNone
-completeModule     = completeNone
-completeHomeModule = completeNone
-completeSetOptions = completeNone
-completeFilename   = completeNone
+completeMacro       = completeNone
+completeIdentifier  = completeNone
+completeModule      = completeNone
+completeHomeModule  = completeNone
+completeSetOptions  = completeNone
+completeShowOptions = completeNone
+completeFilename    = completeNone

 completeHomeModuleOrFile=completeNone
 #endif
 
 completeHomeModuleOrFile=completeNone
 #endif
 

@@ -1817,28 +1837,15 @@ handler exception = do
   ghciHandle handler (showException exception >> return False)
 
 showException :: SomeException -> GHCi ()
   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
        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
 
 -----------------------------------------------------------------------------
 -- recursive exception handlers

@@ -1895,7 +1902,7 @@ wantNameFromInterpretedModule noCanDo str and_then =
    case names of
       []    -> return ()
       (n:_) -> do
    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"
             if not (GHC.isExternalName n)
                then noCanDo n $ ppr n <>
                                 text " is not defined in an interpreted module"

@@ -2067,7 +2074,8 @@ breakSwitch (arg1:rest)
         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
         if GHC.isGoodSrcLoc loc
         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)
                          findBreakByCoord (Just (GHC.srcLocFile loc))
                                           (GHC.srcLocLine loc, 
                                            GHC.srcLocCol loc)

@@ -2214,7 +2222,8 @@ list2 [arg] = do
         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
         if GHC.isGoodSrcLoc loc
                then 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
                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
                                         tickArray

@@ -2237,7 +2246,7 @@ listModuleLine modl line = do
    case this of
      [] -> panic "listModuleLine"
      summ:_ -> 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
 
                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
            io $ listAround (GHC.srcLocSpan loc) False