X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=e0fddacb6d298f47164ff9a02ce8a96c32a5aeac;hb=046feb1ea3b3dafb21c43fda88778198c1c709d6;hp=42424e62398288f80939433e973ede4d1f985255;hpb=bd50bd07d54631d802598b6fb9a6f468afa823cf;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 42424e6..e0fddac 100644
--- 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 ()
@@ -991,8 +992,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 +1003,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
@@ -1299,26 +1302,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
@@ -1896,10 +1883,10 @@ listAround span do_highlight = do
           line_nos = [ fst_line .. ]
 
           highlighted | do_highlight = zipWith highlight line_nos these_lines
-                      | otherwise   = these_lines
+                      | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
 
           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
-          prefixed = zipWith BS.append bs_line_nos highlighted
+          prefixed = zipWith ($) highlighted bs_line_nos
       --
       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
   where
@@ -1916,32 +1903,33 @@ listAround span do_highlight = do
         highlight | do_bold   = highlight_bold
                   | otherwise = highlight_carets
 
-        highlight_bold no line
+        highlight_bold no line prefix
           | no == line1 && no == line2
           = let (a,r) = BS.splitAt col1 line
                 (b,c) = BS.splitAt (col2-col1) r
             in
-            BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
+            BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
           | no == line1
           = let (a,b) = BS.splitAt col1 line in
-            BS.concat [a, BS.pack start_bold, b]
+            BS.concat [prefix, a, BS.pack start_bold, b]
           | no == line2
           = let (a,b) = BS.splitAt col2 line in
-            BS.concat [a, BS.pack end_bold, b]
-          | otherwise   = line
+            BS.concat [prefix, a, BS.pack end_bold, b]
+          | otherwise   = BS.concat [prefix, line]
 
-        highlight_carets no line
+        highlight_carets no line prefix
           | no == line1 && no == line2
-          = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+          = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
                                          BS.replicate (col2-col1) '^']
           | no == line1
-          = BS.concat [line, nl, indent, BS.replicate col1 ' ',
-                                         BS.replicate (BS.length line-col1) '^']
+          = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, 
+                                         prefix, line]
           | no == line2
-          = BS.concat [line, nl, indent, BS.replicate col2 '^']
-          | otherwise   = line
+          = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
+                                         BS.pack "^^"]
+          | otherwise   = BS.concat [prefix, line]
          where
-           indent = BS.pack "   "
+           indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
            nl = BS.singleton '\n'
 
 -- --------------------------------------------------------------------------