X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=0bf37dc4005e408893fc4663c9dc5d34b22a9528;hb=8d180b0dd5b3796c96b162464b93ab1cacc3b789;hp=5f74551d3d454cc4e67e136af4eace7dd0889c57;hpb=f96c7c1a9b509839a452815aa678a66c62a3cfc5;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 5f74551..0bf37dc 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -15,11 +15,13 @@ module InteractiveUI ( -- The GHC interface import qualified GHC -import GHC ( Session, verbosity, dopt, DynFlag(..), +import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..), + TargetId(..), mkModule, pprModule, Type, Module, SuccessFlag(..), TyThing(..), Name, LoadHowMuch(..), Phase, GhcException(..), showGhcException, - CheckedModule(..) ) + CheckedModule(..), SrcLoc ) +import PprTyThing import Outputable -- for createtags (should these come via GHC?) @@ -28,24 +30,15 @@ import Name( nameSrcLoc, nameModule, nameOccName ) import OccName( pprOccName ) import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) --- following all needed for :info... ToDo: remove -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), - IfaceConDecl(..), IfaceType, - pprIfaceDeclHead, pprParendIfaceType, - pprIfaceForAllPart, pprIfaceType ) -import FunDeps ( pprFundeps ) -import SrcLoc ( SrcLoc, pprDefnLoc ) -import OccName ( OccName, parenSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), defaultFixity, failed, successIf ) - -- Other random utilities +import Digraph ( flattenSCCs ) +import BasicTypes ( failed, successIf ) import Panic ( panic, installSignalHandlers ) import Config import StaticFlags ( opt_IgnoreDotGhci ) import Linker ( showLinkerState ) import Util ( removeSpaces, handle, global, toArgs, looksLikeModuleName, prefixMatch, sortLe ) -import ErrUtils ( printErrorsAndWarnings ) #ifndef mingw32_HOST_OS import System.Posix @@ -70,7 +63,7 @@ import Data.Dynamic import Numeric import Data.List import Data.Int ( Int64 ) -import Data.Maybe ( isJust ) +import Data.Maybe ( isJust, fromMaybe, catMaybes ) import System.Cmd import System.CPUTime import System.Environment @@ -115,7 +108,8 @@ builtin_commands = [ ("check", keepGoing checkModule), ("set", keepGoing setCmd), ("show", keepGoing showCmd), - ("tags", keepGoing createTagsFileCmd), + ("etags", keepGoing createETagsFileCmd), + ("ctags", keepGoing createCTagsFileCmd), ("type", keepGoing typeOfExpr), ("kind", keepGoing kindOfType), ("unset", keepGoing unsetOptions), @@ -153,7 +147,8 @@ helpText = " :show modules show the currently loaded modules\n" ++ " :show bindings show the current bindings made at the prompt\n" ++ "\n" ++ - " :tags -e|-c create tags file for Vi (-c) or Emacs (-e)\n" ++ + " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ + " :etags [] create tags file for Emacs (defauilt: \"TAGS\")\n" ++ " :type show the type of \n" ++ " :kind show the kind of \n" ++ " :undef undefine user-defined command :\n" ++ @@ -202,13 +197,6 @@ interactiveUI session srcs maybe_expr = do Readline.initialize #endif -#if defined(mingw32_HOST_OS) - -- The win32 Console API mutates the first character of - -- type-ahead when reading from it in a non-buffered manner. Work - -- around this by flushing the input buffer of type-ahead characters. - -- - GHC.ConsoleHandler.flushConsole stdin -#endif startGHCi (runGHCi srcs maybe_expr) GHCiState{ progname = "", args = [], @@ -271,6 +259,18 @@ runGHCi paths maybe_expr = do case maybe_expr of Nothing -> +#if defined(mingw32_HOST_OS) + do + -- The win32 Console API mutates the first character of + -- type-ahead when reading from it in a non-buffered manner. Work + -- around this by flushing the input buffer of type-ahead characters, + -- but only if stdin is available. + flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin)) + case flushed of + Left err | isDoesNotExistError err -> return () + | otherwise -> io (ioError err) + Right () -> return () +#endif -- enter the interactive loop interactiveLoop is_tty show_prompt Just expr -> do @@ -390,6 +390,11 @@ readlineLoop = do runCommand :: String -> GHCi Bool runCommand c = ghciHandle handler (doCommand c) + where + doCommand (':' : command) = specialCommand command + doCommand stmt + = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) + return False -- This version is for the GHC command-line option -e. The only difference -- from runCommand is that it catches the ExitException exception and @@ -400,6 +405,14 @@ runCommandEval c = ghciHandle handleEval (doCommand c) handleEval e = do showException e io (exitWith (ExitFailure 1)) + doCommand (':' : command) = specialCommand command + doCommand stmt + = do nms <- runStmt stmt + case nms of + Nothing -> io (exitWith (ExitFailure 1)) + -- failure to run the command causes exit(1) for ghc -e. + _ -> finishEvalExpr nms + -- This is the exception handler for exceptions generated by the -- user's code; it normally just prints out the exception. The -- handler must be recursive, in case showing the exception causes @@ -426,29 +439,26 @@ showException (DynException dyn) = showException other_exception = io (putStrLn ("*** Exception: " ++ show other_exception)) -doCommand (':' : command) = specialCommand command -doCommand stmt - = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) - return False - -runStmt :: String -> GHCi [Name] +runStmt :: String -> GHCi (Maybe [Name]) runStmt stmt - | null (filter (not.isSpace) stmt) = return [] + | null (filter (not.isSpace) stmt) = return (Just []) | otherwise = do st <- getGHCiState session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt case result of - GHC.RunFailed -> return [] + GHC.RunFailed -> return Nothing GHC.RunException e -> throw e -- this is caught by runCommand(Eval) - GHC.RunOk names -> return names + GHC.RunOk names -> return (Just names) -- possibly print the type and revert CAFs after evaluating an expression -finishEvalExpr names +finishEvalExpr mb_names = do b <- isOptionSet ShowType session <- getSession - when b (mapM_ (showTypeOfName session) names) + case mb_names of + Nothing -> return () + Just names -> when b (mapM_ (showTypeOfName session) names) flushInterpBuffers io installSignalHandlers @@ -536,126 +546,32 @@ info s = do { let names = words s ; let exts = dopt Opt_GlasgowExts dflags ; mapM_ (infoThing exts session) names } where - infoThing exts session name - = do { stuff <- io (GHC.getInfo session name) - ; unqual <- io (GHC.getPrintUnqual session) - ; io (putStrLn (showSDocForUser unqual $ - vcat (intersperse (text "") (map (showThing exts) stuff)))) } - -showThing :: Bool -> GHC.GetInfoResult -> SDoc -showThing exts (wanted_str, thing, fixity, src_loc, insts) - = vcat [ showWithLoc src_loc (showDecl exts want_name thing), - show_fixity fixity, - vcat (map show_inst insts)] + infoThing exts 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 ])) + + -- Filter out names whose parent is also there Good + -- example is '[]', which is both a type and data + -- constructor in the same type +filterOutChildren :: [Name] -> [Name] +filterOutChildren names = filter (not . parent_is_there) names + where parent_is_there n + | Just p <- GHC.nameParent_maybe n = p `elem` names + | otherwise = False + +pprInfo exts (thing, fixity, insts) + = pprTyThingInContextLoc exts thing + $$ show_fixity fixity + $$ vcat (map GHC.pprInstance insts) where - want_name occ = wanted_str == occNameUserString occ - show_fixity fix - | fix == defaultFixity = empty - | otherwise = ppr fix <+> text wanted_str - - show_inst (inst_ty, loc) - = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty) - -showWithLoc :: SrcLoc -> SDoc -> SDoc -showWithLoc loc doc - = hang doc 2 (char '\t' <> comment <+> pprDefnLoc loc) - -- The tab tries to make them line up a bit - where - comment = ptext SLIT("--") - - --- Now there is rather a lot of goop just to print declarations in a --- civilised way with "..." for the parts we are less interested in. - -showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc -showDecl exts want_name (IfaceForeign {ifName = tc}) - = ppr tc <+> ptext SLIT("is a foreign type") - -showDecl exts want_name (IfaceId {ifName = var, ifType = ty}) - = ppr var <+> dcolon <+> showIfaceType exts ty - -showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) - = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (equals <+> ppr mono_ty) - -showDecl exts want_name (IfaceData {ifName = tycon, - ifTyVars = tyvars, ifCons = condecls, ifCtxt = context}) - = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 2 (add_bars (ppr_trim show_con cs)) - where - show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys, - ifConStricts = strs, ifConFields = flds}) - | want_name tycon || want_name con_name || any want_name flds - = Just (show_guts con_name is_infix tys_w_strs flds) - | otherwise = Nothing - where - tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict) - show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta, - ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs }) - | want_name tycon || want_name con_name - = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau) - | otherwise = Nothing - where - tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict) - pp_tau = foldr add pp_res_ty tys_w_strs - pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys) - add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty - - show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2] - show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys) - show_guts con _ tys flds - = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds)))) - where - show_fld (bty, fld) | want_name tycon || want_name con || want_name fld - = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty) - | otherwise = Nothing - - (pp_nd, cs) = case condecls of - IfAbstractTyCon -> (ptext SLIT("data"), []) - IfDataTyCon cs -> (ptext SLIT("data"), cs) - IfNewTyCon c -> (ptext SLIT("newtype"),[c]) - - add_bars [] = empty - add_bars [c] = equals <+> c - add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs) - - ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty - ppr_str MarkedStrict = char '!' - ppr_str MarkedUnboxed = ptext SLIT("!!") - ppr_str NotMarkedStrict = empty - -showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifSigs = sigs}) - = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars - <+> pprFundeps fds <+> opt_where) - 2 (vcat (ppr_trim show_op sigs)) - where - opt_where | null sigs = empty - | otherwise = ptext SLIT("where") - show_op (IfaceClassOp op dm ty) - | want_name clas || want_name op - = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty) - | otherwise - = Nothing - -showIfaceType :: Bool -> IfaceType -> SDoc -showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls -showIfaceType False ty = ppr ty -- otherwise, print without the foralls - -ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] -ppr_trim show xs - = snd (foldr go (False, []) xs) - where - go x (eliding, so_far) - | Just doc <- show x = (False, doc : so_far) - | otherwise = if eliding then (True, so_far) - else (True, ptext SLIT("...") : so_far) - -ppr_bndr :: OccName -> SDoc --- Wrap operators in () -ppr_bndr occ = parenSymOcc occ (ppr occ) - + | fix == GHC.defaultFixity = empty + | otherwise = ppr fix <+> ppr (GHC.getName thing) ----------------------------------------------------------------------------- -- Commands @@ -678,7 +594,7 @@ changeDirectory dir = do io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) - setContextAfterLoad [] + setContextAfterLoad session [] io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -760,7 +676,7 @@ checkModule :: String -> GHCi () checkModule m = do let modl = mkModule m session <- getSession - result <- io (GHC.checkModule session modl printErrorsAndWarnings) + result <- io (GHC.checkModule session modl) case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( @@ -789,19 +705,39 @@ reloadModule m = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. graph <- io (GHC.getModuleGraph session) - let mods = map GHC.ms_mod graph - mods' <- filterM (io . GHC.isLoaded session) mods - setContextAfterLoad mods' - modulesLoadedMsg ok mods' + graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph + setContextAfterLoad session graph' + modulesLoadedMsg ok (map GHC.ms_mod graph') -setContextAfterLoad [] = do - session <- getSession +setContextAfterLoad session [] = do io (GHC.setContext session [] [prelude_mod]) -setContextAfterLoad (m:_) = do - session <- getSession - b <- io (GHC.moduleIsInterpreted session m) - if b then io (GHC.setContext session [m] []) - else io (GHC.setContext session [] [m]) +setContextAfterLoad session ms = do + -- load a target if one is available, otherwise load the topmost module. + targets <- io (GHC.getTargets session) + case [ m | Just m <- map (findTarget ms) targets ] of + [] -> + let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in + load_this (last graph') + (m:_) -> + load_this m + where + findTarget ms t + = case filter (`matches` t) ms of + [] -> Nothing + (m:_) -> Just m + + summary `matches` Target (TargetModule m) _ + = GHC.ms_mod summary == m + summary `matches` Target (TargetFile f _) _ + | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' + summary `matches` target + = False + + load_this summary | m <- GHC.ms_mod summary = do + b <- io (GHC.moduleIsInterpreted session m) + if b then io (GHC.setContext session [m] []) + else io (GHC.setContext session [] [prelude_mod,m]) + modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi () modulesLoadedMsg ok mods = do @@ -846,10 +782,13 @@ shellEscape str = io (system str >> return False) ----------------------------------------------------------------------------- -- create tags file for currently loaded modules. -createTagsFileCmd :: String -> GHCi () -createTagsFileCmd "-c" = ghciCreateTagsFile CTags "tags" -createTagsFileCmd "-e" = ghciCreateTagsFile ETags "TAGS" -createTagsFileCmd _ = throwDyn (CmdLineError "syntax: :tags -c|-e") +createETagsFileCmd, createCTagsFileCmd :: String -> GHCi () + +createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags" +createCTagsFileCmd file = ghciCreateTagsFile CTags file + +createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" +createETagsFileCmd file = ghciCreateTagsFile ETags file data TagsKind = ETags | CTags @@ -974,16 +913,29 @@ browseModule m exports_only = do (as,bs) <- io (GHC.getContext s) io (if exports_only then GHC.setContext s [] [prelude_mod,modl] else GHC.setContext s [modl] []) + unqual <- io (GHC.getPrintUnqual s) io (GHC.setContext s as bs) - things <- io (GHC.browseModule s modl exports_only) - unqual <- io (GHC.getPrintUnqual s) + mb_mod_info <- io $ GHC.getModuleInfo s modl + case mb_mod_info of + Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m)) + Just mod_info -> do + let names + | exports_only = GHC.modInfoExports mod_info + | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info) - dflags <- getDynFlags - let exts = dopt Opt_GlasgowExts dflags - io (putStrLn (showSDocForUser unqual ( - vcat (map (showDecl exts (const True)) things) - ))) + filtered = filterOutChildren names + + things <- io $ mapM (GHC.lookupName s) filtered + + dflags <- getDynFlags + let exts = dopt Opt_GlasgowExts dflags + io (putStrLn (showSDocForUser unqual ( + vcat (map (pprTyThingInContext exts) (catMaybes things)) + ))) + -- ToDo: modInfoInstances currently throws an exception for + -- package modules. When it works, we can do this: + -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) ----------------------------------------------------------------------------- -- Setting the module context