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
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 ()
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
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
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
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
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
-- 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
-- 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"
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
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'
projects / ghc-hetmet.git / blobdiff