Be a bit more flexible in terminal identification for do_bold

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index fd84f9d..ec1f4bf 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -26,12 +26,12 @@ import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Type, Module, ModuleName, TyThing(..), Phase,
                           BreakIndex, SrcSpan, Resume, SingleStep )
+import PprTyThing
 import DynFlags
 import Packages
 import PackageConfig
 import UniqFM
 import HscTypes                ( implicitTyThings )
-import PprTyThing
 import Outputable       hiding (printForUser)
 import Module           -- for ModuleEnv
 import Name
@@ -610,12 +610,13 @@ afterRunStmt step_here run_result = do
               let namesSorted = sortBy compareNames names
               tythings <- catMaybes `liftM` 
                               io (mapM (GHC.lookupName session) namesSorted)
-              docs_ty  <- mapM showTyThing tythings
-              terms    <- mapM (io . GHC.obtainTermB session 10 False)
-                               [ id | (AnId id, Just _) <- zip tythings docs_ty]
+             let ids = [id | AnId id <- tythings]
+              terms <- mapM (io . GHC.obtainTermB session 10 False) ids
               docs_terms <- mapM (io . showTerm session) terms                                   
-              printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
-                                            (catMaybes docs_ty)
+             dflags <- getDynFlags
+             let pefas = dopt Opt_PrintExplicitForalls dflags
+              printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
+                                            (map (pprTyThing pefas . AnId) ids)
                                             docs_terms
 
 runBreakCmd :: GHC.BreakInfo -> GHCi ()
@@ -932,10 +933,9 @@ doLoad session howmuch = do
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
   discardTickArrays
-  graph <- io (GHC.getModuleGraph session)
-  graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
-  setContextAfterLoad session graph'
-  modulesLoadedMsg ok (map GHC.ms_mod_name graph')
+  loaded_mods <- getLoadedModules session
+  setContextAfterLoad session loaded_mods
+  modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
 
 setContextAfterLoad session [] = do
   prel_mod <- getPrelude
@@ -991,8 +991,10 @@ typeOfExpr str
        maybe_ty <- io (GHC.exprType cms str)
        case maybe_ty of
          Nothing -> return ()
-         Just ty -> do ty' <- cleanType ty
-                        printForUser $ text str <> text " :: " <> ppr ty'
+         Just ty -> do dflags <- getDynFlags
+                       let pefas = dopt Opt_PrintExplicitForalls dflags
+                        printForUser $ text str <+> dcolon
+                                       <+> pprTypeForUser pefas ty
 
 kindOfType :: String -> GHCi ()
 kindOfType str 
@@ -1000,7 +1002,7 @@ kindOfType str
        maybe_ty <- io (GHC.typeKind cms str)
        case maybe_ty of
          Nothing    -> return ()
-         Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
+         Just ty    -> printForUser $ text str <+> dcolon <+> ppr ty
           
 quit :: String -> GHCi Bool
 quit _ = return True
@@ -1284,10 +1286,15 @@ showCmd str = do
 
 showModules = do
   session <- getSession
-  let show_one ms = do m <- io (GHC.showModule session ms)
-                      io (putStrLn m)
+  loaded_mods <- getLoadedModules session
+        -- we want *loaded* modules only, see #1734
+  let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
+  mapM_ show_one loaded_mods
+
+getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
+getLoadedModules session = do
   graph <- io (GHC.getModuleGraph session)
-  mapM_ show_one graph
+  filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 
 showBindings = do
   s <- getSession
@@ -1299,26 +1306,10 @@ showBindings = do
 compareTyThings :: TyThing -> TyThing -> Ordering
 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
 
-showTyThing :: TyThing -> GHCi (Maybe SDoc)
-showTyThing (AnId id) = do
-  ty' <- cleanType (GHC.idType id)
-  return $ Just $ ppr id <> text " :: " <> ppr ty'
-showTyThing _ = return Nothing
-
 printTyThing :: TyThing -> GHCi ()
-printTyThing tyth = do
-  mb_x <- showTyThing tyth
-  case mb_x of
-    Just x  -> printForUser x
-    Nothing -> return ()
-
--- if -fglasgow-exts is on we show the foralls, otherwise we don't.
-cleanType :: Type -> GHCi Type
-cleanType ty = do
-  dflags <- getDynFlags
-  if dopt Opt_PrintExplicitForalls dflags 
-       then return ty
-       else return $! GHC.dropForAlls ty
+printTyThing tyth = do dflags <- getDynFlags
+                       let pefas = dopt Opt_PrintExplicitForalls dflags
+                      printForUser (pprTyThing pefas tyth)
 
 showBkptTable :: GHCi ()
 showBkptTable = do
@@ -1549,14 +1540,17 @@ setUpConsole = do
        -- similarly for characters we write to the console.
        --
        -- At the moment, GHCi pretends all input is Latin-1.  In the
-       -- future we should support UTF-8, but for now we set the code pages
-       -- to Latin-1.
+       -- future we should support UTF-8, but for now we set the code
+       -- pages to Latin-1.  Doing it this way does lead to problems,
+       -- however: see bug #1649.
        --
        -- It seems you have to set the font in the console window to
        -- a Unicode font in order for output to work properly,
        -- otherwise non-ASCII characters are mapped wrongly.  sigh.
        -- (see MSDN for SetConsoleOutputCP()).
        --
+        -- This call has been known to hang on some machines, see bug #1483
+        --
        setConsoleCP 28591       -- ISO Latin-1
        setConsoleOutputCP 28591 -- ISO Latin-1
 #endif
@@ -1824,8 +1818,9 @@ findBreakByCoord mb_file (line, col) arr
 -- 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"]
+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
+    where mTerm = System.Environment.getEnv "TERM"
+                  `Exception.catch` \e -> return "TERM not set"
 
 start_bold :: String
 start_bold = "\ESC[1m"