Require a bang pattern when unlifted types are where/let bound; #3182

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index b5d66a1..e0c49ce 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" ++

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

@@ -339,13 +335,11 @@ interactiveUI srcs maybe_exprs = do
 #endif
 
    -- initial context is just the Prelude
 #endif
 
    -- initial context is just the Prelude

-   prel_mod <- GHC.findModule (GHC.mkModuleName "Prelude") Nothing
+   prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing

    GHC.setContext [] [prel_mod]
 
    default_editor <- liftIO $ findEditor
 
    GHC.setContext [] [prel_mod]
 
    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 = 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
                  }
 

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

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

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

@@ -725,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 ()
 

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

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

@@ -1202,15 +1215,20 @@ 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 [utext str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]

 
 kindOfType :: String -> GHCi ()
 kindOfType str 
   = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
        ty <- GHC.typeKind str
 
 kindOfType :: String -> GHCi ()
 kindOfType str 
   = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
        ty <- GHC.typeKind str

-       printForUser $ text str <+> dcolon <+> ppr ty
+       printForUser $ utext str <+> dcolon <+> ppr ty

           
           

+-- HACK for printing unicode text.  We assume the output device
+-- understands UTF-8, and go via FastString which converts to UTF-8.
+-- ToDo: fix properly when we have encoding support in Handles.
+utext :: String -> SDoc
+utext str = ftext (mkFastString str)
+

 quit :: String -> GHCi Bool
 quit _ = return True
 
 quit :: String -> GHCi Bool
 quit _ = return True
 

@@ -1484,10 +1502,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.)

@@ -1501,7 +1522,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

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

@@ -1739,7 +1760,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

@@ -1789,12 +1817,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
 

@@ -1955,7 +1984,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 ()
 

@@ -2228,7 +2257,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
 

@@ -2327,7 +2356,7 @@ mkTickArray ticks
 
 lookupModule :: String -> GHCi Module
 lookupModule modName
 
 lookupModule :: String -> GHCi Module
 lookupModule modName

-   = GHC.findModule (GHC.mkModuleName modName) Nothing
+   = GHC.lookupModule (GHC.mkModuleName modName) Nothing

 
 -- don't reset the counter back to zero?
 discardActiveBreakPoints :: GHCi ()
 
 -- don't reset the counter back to zero?
 discardActiveBreakPoints :: GHCi ()