X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=ec1f4bf98e892080e81cd0c69650f2ea552883ab;hb=9efeaae7dd6d720b0f44b0a73ed4881d7eb41034;hp=e45e738a5b3364e8a72c62f2139b285aa8f3c9d5;hpb=5ac833ec6a3ecb038249e5ea9c43b372f77481b5;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index e45e738..ec1f4bf 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 () @@ -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" @@ -1896,10 +1891,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,30 +1911,31 @@ 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 (" " ++ replicate (length (show no)) ' ') nl = BS.singleton '\n'