X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=169168f8f25ddcc461a1c29434bcc7f0cdfc6f8b;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hp=0fd8b4e08dee57ecafb012d6f4755f2d67060fd9;hpb=cedd4187afc6fabf7884a6dc42c3c47ea09624a3;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 0fd8b4e..169168f 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,7 +6,7 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -module InteractiveUI ( interactiveUI ) where +module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -18,7 +18,7 @@ import Debugger import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, - BreakIndex, Name, SrcSpan, Resume, SingleStep ) + BreakIndex, SrcSpan, Resume, SingleStep ) import DynFlags import Packages import PackageConfig @@ -26,6 +26,7 @@ import UniqFM import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv +import Name -- Other random utilities import Digraph @@ -80,16 +81,9 @@ import System.Posix.Internals ( setNonBlockingFD ) ----------------------------------------------------------------------------- -ghciWelcomeMsg = - " ___ ___ _\n"++ - " / _ \\ /\\ /\\/ __(_)\n"++ - " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++ - "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++ - "\\____/\\/ /_/\\____/|_| Type :? for help.\n" - -ghciShortWelcomeMsg = - "GHCi, version " ++ cProjectVersion ++ - ": http://www.haskell.org/ghc/ :? for help" +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) cmdName (n,_,_,_) = n @@ -365,11 +359,6 @@ runGHCi paths maybe_expr = do -- initialise the console if necessary io setUpConsole - let msg = if dopt Opt_ShortGhciBanner dflags - then ghciShortWelcomeMsg - else ghciWelcomeMsg - when (verbosity dflags >= 1) $ io $ putStrLn msg - -- enter the interactive loop interactiveLoop is_tty show_prompt Just expr -> do @@ -576,12 +565,12 @@ afterRunStmt run_result = do case run_result of GHC.RunOk names -> do show_types <- isOptionSet ShowType - when show_types $ mapM_ (showTypeOfName session) names + when show_types $ printTypeOfNames session names GHC.RunBreak _ names mb_info -> do resumes <- io $ GHC.getResumeContext session printForUser $ ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan (head resumes)) - mapM_ (showTypeOfName session) names + printTypeOfNames session names maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState @@ -608,12 +597,20 @@ runBreakCmd info = do | otherwise -> do enqueueCommands [cmd]; return () where cmd = onBreakCmd loc -showTypeOfName :: Session -> Name -> GHCi () -showTypeOfName session n +printTypeOfNames :: Session -> [Name] -> GHCi () +printTypeOfNames session names + = mapM_ (printTypeOfName session) $ sortBy compareNames names + +compareNames :: Name -> Name -> Ordering +n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2 + where compareWith n = (getOccString n, getSrcSpan n) + +printTypeOfName :: Session -> Name -> GHCi () +printTypeOfName session n = do maybe_tything <- io (GHC.lookupName session n) - case maybe_tything of - Nothing -> return () - Just thing -> showTyThing thing + case maybe_tything of + Nothing -> return () + Just thing -> printTyThing thing specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) @@ -631,7 +628,7 @@ lookupCommand str = do -- look for exact match first, then the first prefix match case [ c | c <- cmds, str == cmdName c ] of c:_ -> return (Just c) - [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of + [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of [] -> return Nothing c:_ -> return (Just c) @@ -666,17 +663,17 @@ info "" = throwDyn (CmdLineError "syntax: ':i '") info s = do { let names = words s ; session <- getSession ; dflags <- getDynFlags - ; let exts = dopt Opt_GlasgowExts dflags - ; mapM_ (infoThing exts session) names } + ; let pefas = dopt Opt_PrintExplicitForalls dflags + ; mapM_ (infoThing pefas session) names } where - infoThing exts session str = io $ do + infoThing pefas session str = io $ do names <- GHC.parseName session str let filtered = filterOutChildren names mb_stuffs <- mapM (GHC.getInfo session) filtered unqual <- GHC.getPrintUnqual session putStrLn (showSDocForUser unqual $ vcat (intersperse (text "") $ - [ pprInfo exts stuff | Just stuff <- mb_stuffs ])) + [ pprInfo pefas stuff | Just stuff <- mb_stuffs ])) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -688,8 +685,9 @@ filterOutChildren names = filter (not . parent_is_there) names -- ToDo!! | otherwise = False -pprInfo exts (thing, fixity, insts) - = pprTyThingInContextLoc exts thing +pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc +pprInfo pefas (thing, fixity, insts) + = pprTyThingInContextLoc pefas thing $$ show_fixity fixity $$ vcat (map GHC.pprInstance insts) where @@ -856,7 +854,7 @@ checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m session <- getSession - result <- io (GHC.checkModule session modl) + result <- io (GHC.checkModule session modl False) case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( @@ -1003,9 +1001,9 @@ browseModule m exports_only = do things <- io $ mapM (GHC.lookupName s) filtered dflags <- getDynFlags - let exts = dopt Opt_GlasgowExts dflags + let pefas = dopt Opt_PrintExplicitForalls dflags io (putStrLn (showSDocForUser unqual ( - vcat (map (pprTyThingInContext exts) (catMaybes things)) + vcat (map (pprTyThingInContext pefas) (catMaybes things)) ))) -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: @@ -1251,19 +1249,23 @@ showBindings = do s <- getSession unqual <- io (GHC.getPrintUnqual s) bindings <- io (GHC.getBindings s) - mapM_ showTyThing bindings + mapM_ printTyThing $ sortBy compareTyThings bindings return () -showTyThing (AnId id) = do +compareTyThings :: TyThing -> TyThing -> Ordering +t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 + +printTyThing :: TyThing -> GHCi () +printTyThing (AnId id) = do ty' <- cleanType (GHC.idType id) printForUser $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return () +printTyThing _ = 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_GlasgowExts dflags + if dopt Opt_PrintExplicitForalls dflags then return ty else return $! GHC.dropForAlls ty @@ -1586,7 +1588,7 @@ backCmd = noArgs $ do s <- getSession (names, ix, span) <- io $ GHC.back s printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span - mapM_ (showTypeOfName s) names + printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] @@ -1598,7 +1600,7 @@ forwardCmd = noArgs $ do printForUser $ (if (ix == 0) then ptext SLIT("Stopped at") else ptext SLIT("Logged breakpoint at")) <+> ppr span - mapM_ (showTypeOfName s) names + printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] @@ -1640,14 +1642,17 @@ breakByModule :: Session -> Module -> [String] -> GHCi () breakByModule session mod args@(arg1:rest) | all isDigit arg1 = do -- looks like a line number breakByModuleLine mod (read arg1) rest - | otherwise = io $ putStrLn "Invalid arguments to :break" +breakByModule session mod _ + = breakSyntax breakByModuleLine :: Module -> Int -> [String] -> GHCi () breakByModuleLine mod line args | [] <- args = findBreakAndSet mod $ findBreakByLine line | [col] <- args, all isDigit col = findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) - | otherwise = io $ putStrLn "Invalid arguments to :break" + | otherwise = breakSyntax + +breakSyntax = throwDyn (CmdLineError "Syntax: :break [] []") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do @@ -1800,8 +1805,7 @@ listModuleLine modl line = do -- If the highlight flag is True, also highlight the span using -- start_bold/end_bold. listAround span do_highlight = do - pwd <- getEnv "PWD" - contents <- BS.readFile (pwd `joinFileName` unpackFS file) + contents <- BS.readFile (unpackFS file) let lines = BS.split '\n' contents these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $