add final newlines

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 268f05e..9feae0e 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 )

@@ -96,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

@@ -147,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), 

@@ -255,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" ++

@@ -344,8 +340,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ 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 = [],

@@ -361,7 +355,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ 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
                  }
 

@@ -641,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.

@@ -740,23 +730,19 @@ afterRunStmt step_here run_result = do
      GHC.RunOk names -> do
         show_types <- isOptionSet ShowType
         when show_types $ printTypeOfNames names
      GHC.RunOk names -> do
         show_types <- isOptionSet ShowType
         when show_types $ printTypeOfNames names

-     GHC.RunBreak _ names mb_info 
-         | isNothing  mb_info || 
+     GHC.RunBreak _ names mb_info
+         | isNothing  mb_info ||

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

-               printForUser $ ptext (sLit "Stopped at") <+> 
-                       ppr (GHC.resumeSpan $ head resumes)
---               printTypeOfNames session names
-               let namesSorted = sortBy compareNames names
-               tythings <- catMaybes `liftM` 
-                              mapM GHC.lookupName namesSorted
-               docs <- pprTypeAndContents [id | AnId id <- tythings]
-               printForUserPartWay docs
-               maybe (return ()) runBreakCmd mb_info
+               mb_id_loc <- toBreakIdAndLocation mb_info
+               let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
+               if (null breakCmd)
+                 then printStoppedAtBreakInfo (head resumes) names
+                 else enqueueCommands [breakCmd]

                -- run the command set with ":set stop <cmd>"
                st <- getGHCiState
                enqueueCommands [stop st]
                return ()
                -- run the command set with ":set stop <cmd>"
                st <- getGHCiState
                enqueueCommands [stop st]
                return ()

-         | otherwise -> resume GHC.SingleStep >>=
+         | otherwise -> resume step_here GHC.SingleStep >>=

                         afterRunStmt step_here >> return ()
      _ -> return ()
 
                         afterRunStmt step_here >> return ()
      _ -> return ()
 

@@ -767,17 +753,26 @@ afterRunStmt step_here run_result = do
 
   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 
 
   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 

-runBreakCmd :: GHC.BreakInfo -> GHCi ()
-runBreakCmd info = do
+toBreakIdAndLocation ::
+  Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
+toBreakIdAndLocation Nothing = return Nothing
+toBreakIdAndLocation (Just info) = do

   let mod = GHC.breakInfo_module info
       nm  = GHC.breakInfo_number info
   st <- getGHCiState
   let mod = GHC.breakInfo_module info
       nm  = GHC.breakInfo_number info
   st <- getGHCiState

-  case  [ loc | (_,loc) <- breaks st,
-                breakModule loc == mod, breakTick loc == nm ] of
-        []  -> return ()
-        loc:_ | null cmd  -> return ()
-              | otherwise -> do enqueueCommands [cmd]; return ()
-              where cmd = onBreakCmd loc
+  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
+                                  breakModule loc == mod,
+                                  breakTick loc == nm ]
+
+printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
+printStoppedAtBreakInfo resume names = do
+  printForUser $ ptext (sLit "Stopped at") <+>
+    ppr (GHC.resumeSpan resume)
+  --  printTypeOfNames session names
+  let namesSorted = sortBy compareNames names
+  tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
+  docs <- pprTypeAndContents [id | AnId id <- tythings]
+  printForUserPartWay docs

 
 printTypeOfNames :: [Name] -> GHCi ()
 printTypeOfNames names
 
 printTypeOfNames :: [Name] -> GHCi ()
 printTypeOfNames names

@@ -1040,6 +1035,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
 

@@ -1217,8 +1215,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 

@@ -1499,10 +1496,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.)

@@ -1516,7 +1516,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

@@ -1679,8 +1679,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

@@ -1754,9 +1754,15 @@ completeHomeModule w = do
 
 completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)
 
 completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)

-    where options = "args":"prog":flagList
+    where options = "args":"prog":"prompt":"editor":"stop":flagList

           flagList = map head $ group $ sort allFlags
 
           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
     case ws of
 completeFilename w = do
     ws <- Readline.filenameCompletionFunction w
     case ws of

@@ -1805,12 +1811,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
 

@@ -1971,7 +1978,7 @@ continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
 -- doContinue :: SingleStep -> GHCi ()
 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
 doContinue pred step = do 
 -- doContinue :: SingleStep -> GHCi ()
 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
 doContinue pred step = do 

-  runResult <- resume step
+  runResult <- resume pred step

   afterRunStmt pred runResult
   return ()
 
   afterRunStmt pred runResult
   return ()
 

@@ -2244,7 +2251,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