X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=0bf37dc4005e408893fc4663c9dc5d34b22a9528;hb=8d180b0dd5b3796c96b162464b93ab1cacc3b789;hp=1648773984c8e151b3cd84d2b2b72175fcdaa667;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 1648773..0bf37dc 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,53 +1,55 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.176 2004/09/30 10:36:47 simonpj Exp $ -- -- GHC Interactive User Interface -- --- (c) The GHC Team 2004 +-- (c) The GHC Team 2005 -- ----------------------------------------------------------------------------- module InteractiveUI ( - interactiveUI, -- :: CmState -> [FilePath] -> IO () + interactiveUI, ghciWelcomeMsg ) where -#include "../includes/ghcconfig.h" #include "HsVersions.h" -import CompManager -import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, - isObjectLinkable, GhciMode(..) ) -import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), - IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) -import FunDeps ( pprFundeps ) -import DriverFlags -import DriverState -import DriverUtil ( remove_spaces ) -import Linker ( showLinkerState, linkPackages ) -import Util -import Module ( showModMsg, lookupModuleEnv ) -import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, - NamedThing(..) ) -import OccName ( OccName, isSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) ) -import Packages +-- The GHC interface +import qualified GHC +import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..), + TargetId(..), + mkModule, pprModule, Type, Module, SuccessFlag(..), + TyThing(..), Name, LoadHowMuch(..), Phase, + GhcException(..), showGhcException, + CheckedModule(..), SrcLoc ) +import PprTyThing import Outputable -import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, - restoreDynFlags, dopt_unset ) -import Panic hiding ( showException ) + +-- for createtags (should these come via GHC?) +import Module( moduleUserString ) +import Name( nameSrcLoc, nameModule, nameOccName ) +import OccName( pprOccName ) +import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) + +-- Other random utilities +import Digraph ( flattenSCCs ) +import BasicTypes ( failed, successIf ) +import Panic ( panic, installSignalHandlers ) import Config -import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import StaticFlags ( opt_IgnoreDotGhci ) +import Linker ( showLinkerState ) +import Util ( removeSpaces, handle, global, toArgs, + looksLikeModuleName, prefixMatch, sortLe ) #ifndef mingw32_HOST_OS -import DriverUtil( handle ) import System.Posix #if __GLASGOW_HASKELL__ > 504 hiding (getEnv) #endif +#else +import GHC.ConsoleHandler ( flushConsole ) #endif -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE import Control.Concurrent ( yield ) -- Used in readline loop import System.Console.Readline as Readline #endif @@ -56,21 +58,25 @@ import System.Console.Readline as Readline import Control.Exception as Exception import Data.Dynamic -import Control.Concurrent +-- import Control.Concurrent import Numeric import Data.List import Data.Int ( Int64 ) +import Data.Maybe ( isJust, fromMaybe, catMaybes ) import System.Cmd import System.CPUTime import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) import System.Directory -import System.IO as IO +import System.IO +import System.IO.Error as IO import Data.Char import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) +import GHC.IOBase ( IOErrorType(InvalidArgument) ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) @@ -96,11 +102,14 @@ builtin_commands = [ ("help", keepGoing help), ("?", keepGoing help), ("info", keepGoing info), - ("load", keepGoingPaths loadModule), + ("load", keepGoingPaths loadModule_), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), + ("check", keepGoing checkModule), ("set", keepGoing setCmd), ("show", keepGoing showCmd), + ("etags", keepGoing createETagsFileCmd), + ("ctags", keepGoing createCTagsFileCmd), ("type", keepGoing typeOfExpr), ("kind", keepGoing kindOfType), ("unset", keepGoing unsetOptions), @@ -138,6 +147,8 @@ helpText = " :show modules show the currently loaded modules\n" ++ " :show bindings show the current bindings made at the prompt\n" ++ "\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" ++ @@ -154,11 +165,8 @@ helpText = " (eg. -v2, -fglasgow-exts, etc.)\n" -interactiveUI :: [FilePath] -> Maybe String -> IO () -interactiveUI srcs maybe_expr = do - dflags <- getDynFlags - - cmstate <- cmInit Interactive dflags; +interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () +interactiveUI session srcs maybe_expr = do -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block @@ -176,35 +184,34 @@ interactiveUI srcs maybe_expr = do hSetBuffering stdout NoBuffering -- Initialise buffering for the *interpreted* I/O system - initInterpBuffering cmstate + initInterpBuffering session -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -- initial context is just the Prelude - cmstate <- cmSetContext cmstate [] ["Prelude"] + GHC.setContext session [] [prelude_mod] -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE Readline.initialize #endif - startGHCi (runGHCi srcs dflags maybe_expr) + startGHCi (runGHCi srcs maybe_expr) GHCiState{ progname = "", args = [], - targets = srcs, - cmstate = cmstate, + session = session, options = [] } -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE Readline.resetTerminal Nothing #endif return () -runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi () -runGHCi paths dflags maybe_expr = do - read_dot_files <- io (readIORef v_Read_DotGHCi) +runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () +runGHCi paths maybe_expr = do + let read_dot_files = not opt_IgnoreDotGhci when (read_dot_files) $ do -- Read in ./.ghci. @@ -236,22 +243,39 @@ runGHCi paths dflags maybe_expr = do Right hdl -> fileLoop hdl False -- Perform a :load for files given on the GHCi command line - when (not (null paths)) $ - ghciHandle showException $ - loadModule paths + -- When in -e mode, if the load fails then we want to stop + -- immediately rather than going on to evaluate the expression. + when (not (null paths)) $ do + ok <- ghciHandle (\e -> do showException e; return Failed) $ + loadModule paths + when (isJust maybe_expr && failed ok) $ + io (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. is_tty <- io (hIsTerminalDevice stdin) + dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty 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 -- just evaluate the expression we were given - runCommand expr + runCommandEval expr return () -- and finally, exit @@ -261,11 +285,15 @@ runGHCi paths dflags maybe_expr = do interactiveLoop is_tty show_prompt = do -- Ignore ^C exceptions caught here ghciHandleDyn (\e -> case e of - Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt) + Interrupted -> ghciUnblock ( +#if defined(mingw32_HOST_OS) + io (putStrLn "") >> +#endif + interactiveLoop is_tty show_prompt) _other -> return ()) $ do -- read commands from stdin -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE if (is_tty) then readlineLoop else fileLoop stdin show_prompt @@ -288,7 +316,7 @@ checkPerms name = #ifdef mingw32_HOST_OS return True #else - DriverUtil.handle (\_ -> return False) $ do + Util.handle (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID if fileOwner st /= me then do @@ -307,15 +335,21 @@ checkPerms name = fileLoop :: Handle -> Bool -> GHCi () fileLoop hdl prompt = do - cmstate <- getCmState - (mod,imports) <- io (cmGetContext cmstate) + session <- getSession + (mod,imports) <- io (GHC.getContext session) when prompt (io (putStr (mkPrompt mod imports))) l <- io (IO.try (hGetLine hdl)) case l of - Left e | isEOFError e -> return () - | otherwise -> io (ioError e) + Left e | isEOFError e -> return () + | InvalidArgument <- etype -> return () + | otherwise -> io (ioError e) + where etype = ioeGetErrorType e + -- treat InvalidArgument in the same way as EOF: + -- this can happen if the user closed stdin, or + -- perhaps did getContents which closes stdin at + -- EOF. Right l -> - case remove_spaces l of + case removeSpaces l of "" -> fileLoop hdl prompt l -> do quit <- runCommand l if quit then return () else fileLoop hdl prompt @@ -323,19 +357,21 @@ fileLoop hdl prompt = do stringLoop :: [String] -> GHCi () stringLoop [] = return () stringLoop (s:ss) = do - case remove_spaces s of + case removeSpaces s of "" -> stringLoop ss l -> do quit <- runCommand l if quit then return () else stringLoop ss mkPrompt toplevs exports - = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> " + = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs) + <+> hsep (map pprModule exports) + <> text "> ") -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE readlineLoop :: GHCi () readlineLoop = do - cmstate <- getCmState - (mod,imports) <- io (cmGetContext cmstate) + session <- getSession + (mod,imports) <- io (GHC.getContext session) io yield l <- io (readline (mkPrompt mod imports) `finally` setNonBlockingFD 0) @@ -344,7 +380,7 @@ readlineLoop = do case l of Nothing -> return () Just l -> - case remove_spaces l of + case removeSpaces l of "" -> readlineLoop l -> do io (addHistory l) @@ -354,6 +390,28 @@ 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 +-- exits, rather than printing out the exception. +runCommandEval c = ghciHandle handleEval (doCommand c) + where + handleEval (ExitException code) = io (exitWith code) + 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 @@ -381,33 +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 - dflags <- io getDynFlags - let cm_state' = cmSetDFlags (cmstate st) - (dopt_unset dflags Opt_WarnUnusedBinds) - (new_cmstate, result) <- - io $ withProgName (progname st) $ withArgs (args st) $ - cmRunStmt cm_state' stmt - setGHCiState st{cmstate = new_cmstate} + session <- getSession + result <- io $ withProgName (progname st) $ withArgs (args st) $ + GHC.runStmt session stmt case result of - CmRunFailed -> return [] - CmRunException e -> showException e >> return [] - CmRunOk names -> return names + GHC.RunFailed -> return Nothing + GHC.RunException e -> throw e -- this is caught by runCommand(Eval) + 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 - cmstate <- getCmState - when b (mapM_ (showTypeOfName cmstate) names) + session <- getSession + case mb_names of + Nothing -> return () + Just names -> when b (mapM_ (showTypeOfName session) names) flushInterpBuffers io installSignalHandlers @@ -415,12 +466,18 @@ finishEvalExpr names io (when b revertCAFs) return True -showTypeOfName :: CmState -> Name -> GHCi () -showTypeOfName cmstate n - = do maybe_str <- io (cmTypeOfName cmstate n) - case maybe_str of - Nothing -> return () - Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str)) +showTypeOfName :: Session -> Name -> GHCi () +showTypeOfName session n + = do maybe_tything <- io (GHC.lookupName session n) + case maybe_tything of + Nothing -> return () + Just thing -> showTyThing thing + +showForUser :: SDoc -> GHCi String +showForUser doc = do + session <- getSession + unqual <- io (GHC.getPrintUnqual session) + return $! showSDocForUser unqual doc specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) @@ -436,9 +493,6 @@ specialCommand str = do foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")") >> return False) -noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments")) - - ----------------------------------------------------------------------------- -- To flush buffers for the *interpreted* computation we need -- to refer to *its* stdout/stderr handles @@ -446,19 +500,19 @@ noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments")) GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) -no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++ - " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" -flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr" +no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ + " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" +flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr" -initInterpBuffering :: CmState -> IO () -initInterpBuffering cmstate - = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd +initInterpBuffering :: Session -> IO () +initInterpBuffering session + = do maybe_hval <- GHC.compileExpr session no_buf_cmd case maybe_hval of Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) other -> panic "interactiveUI:setBuffering" - maybe_hval <- cmCompileExpr cmstate flush_cmd + maybe_hval <- GHC.compileExpr session flush_cmd case maybe_hval of Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:flush" @@ -487,147 +541,61 @@ help _ = io (putStr helpText) info :: String -> GHCi () info "" = throwDyn (CmdLineError "syntax: ':i '") info s = do { let names = words s - ; init_cms <- getCmState - ; mapM_ (infoThing init_cms) names } + ; session <- getSession + ; dflags <- getDynFlags + ; let exts = dopt Opt_GlasgowExts dflags + ; mapM_ (infoThing exts session) names } where - infoThing cms name - = do { stuff <- io (cmGetInfo cms name) - ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $ - vcat (intersperse (text "") (map showThing stuff)))) } - -showThing :: GetInfoResult -> SDoc -showThing (wanted_str, (thing, fixity, src_loc, insts)) - = vcat [ showDecl want_name thing, - show_fixity fixity, - show_loc src_loc, - 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_loc loc -- The ppr function for SrcLocs is a bit wonky - | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc - | otherwise = comment <+> ppr loc - comment = ptext SLIT("--") - - show_inst (iface_inst, loc) - = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst)) - 2 (char '\t' <> show_loc loc) - -- The tab tries to make them line up a bit - --- 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 :: (OccName -> Bool) -> IfaceDecl -> SDoc -showDecl want_name (IfaceForeign {ifName = tc}) - = ppr tc <+> ptext SLIT("is a foreign type") - -showDecl want_name (IfaceId {ifName = var, ifType = ty}) - = ppr var <+> dcolon <+> ppr ty - -showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) - = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (equals <+> ppr mono_ty) - -showDecl want_name (IfaceData {ifName = tycon, - ifTyVars = tyvars, ifCons = condecls}) - = 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, context, cs) = case condecls of - IfAbstractTyCon -> (ptext SLIT("data"), [], []) - IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs) - IfDataTyCon Nothing 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 want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifSigs = sigs}) - = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars - <+> pprFundeps fds <+> ptext SLIT("where")) - 2 (vcat (ppr_trim show_op sigs)) - where - show_op (IfaceClassOp op dm ty) - | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty) - | otherwise = Nothing - -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 | isSymOcc occ = parens (ppr occ) - | otherwise = ppr occ - + | fix == GHC.defaultFixity = empty + | otherwise = ppr fix <+> ppr (GHC.getName thing) ----------------------------------------------------------------------------- -- Commands addModule :: [FilePath] -> GHCi () addModule files = do - state <- getGHCiState io (revertCAFs) -- always revert CAFs on load/add. files <- mapM expandPath files - let new_targets = files ++ targets state - graph <- io (cmDepAnal (cmstate state) new_targets) - (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph) - setGHCiState state{ cmstate = cmstate1, targets = new_targets } - setContextAfterLoad mods - dflags <- io getDynFlags - modulesLoadedMsg ok mods dflags + targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files + session <- getSession + io (mapM_ (GHC.addTarget session) targets) + ok <- io (GHC.load session LoadAllTargets) + afterLoad ok session changeDirectory :: String -> GHCi () changeDirectory dir = do - state <- getGHCiState - when (targets state /= []) $ + session <- getSession + graph <- io (GHC.getModuleGraph session) + when (not (null graph)) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" - cmstate1 <- io (cmUnload (cmstate state)) - setGHCiState state{ cmstate = cmstate1, targets = [] } - setContextAfterLoad [] + io (GHC.setTargets session []) + io (GHC.load session LoadAllTargets) + setContextAfterLoad session [] + io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -648,14 +616,14 @@ defineMacro s = do let new_expr = '(' : definition ++ ") :: String -> IO String" -- compile the expression - cms <- getCmState - maybe_hv <- io (cmCompileExpr cms new_expr) + cms <- getSession + maybe_hv <- io (GHC.compileExpr cms new_expr) case maybe_hv of Nothing -> return () Just hv -> io (writeIORef commands -- ((macro_name, keepGoing (runMacro hv)) : cmds)) -runMacro :: HValue{-String -> IO String-} -> String -> GHCi () +runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi () runMacro fun s = do str <- io ((unsafeCoerce# fun :: String -> IO String) s) stringLoop (lines str) @@ -674,65 +642,111 @@ undefineMacro macro_name = do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) -loadModule :: [FilePath] -> GHCi () +loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) -loadModule' :: [FilePath] -> GHCi () -loadModule' files = do - state <- getGHCiState - - -- expand tildes - files <- mapM expandPath files - - -- do the dependency anal first, so that if it fails we don't throw - -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) files) +loadModule_ :: [FilePath] -> GHCi () +loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () - -- Dependency anal ok, now unload everything - cmstate1 <- io (cmUnload (cmstate state)) - setGHCiState state{ cmstate = cmstate1, targets = [] } - - io (revertCAFs) -- always revert CAFs on load. - (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph) - setGHCiState state{ cmstate = cmstate2, targets = files } +loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag +loadModule' files = do + session <- getSession - setContextAfterLoad mods - dflags <- io (getDynFlags) - modulesLoadedMsg ok mods dflags + -- unload first + io (GHC.setTargets session []) + io (GHC.load session LoadAllTargets) + -- expand tildes + let (filenames, phases) = unzip files + exp_filenames <- mapM expandPath filenames + let files' = zip exp_filenames phases + targets <- io (mapM (uncurry GHC.guessTarget) files') + + -- NOTE: we used to do the dependency anal first, so that if it + -- fails we didn't throw away the current set of modules. This would + -- require some re-working of the GHC interface, so we'll leave it + -- as a ToDo for now. + + io (GHC.setTargets session targets) + ok <- io (GHC.load session LoadAllTargets) + afterLoad ok session + return ok + +checkModule :: String -> GHCi () +checkModule m = do + let modl = mkModule m + session <- getSession + result <- io (GHC.checkModule session modl) + case result of + Nothing -> io $ putStrLn "Nothing" + Just r -> io $ putStrLn (showSDoc ( + case checkedModuleInfo r of + Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> + let + (local,global) = partition ((== modl) . GHC.nameModule) scope + in + (text "global names: " <+> ppr global) $$ + (text "local names: " <+> ppr local) + _ -> empty)) + afterLoad (successIf (isJust result)) session reloadModule :: String -> GHCi () reloadModule "" = do - state <- getGHCiState - case targets state of - [] -> io (putStr "no current target\n") - paths -> do - -- do the dependency anal first, so that if it fails we don't throw - -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) paths) - - io (revertCAFs) -- always revert CAFs on reload. - (cmstate1, ok, mods) - <- io (cmLoadModules (cmstate state) graph) - setGHCiState state{ cmstate=cmstate1 } - setContextAfterLoad mods - dflags <- io getDynFlags - modulesLoadedMsg ok mods dflags - -reloadModule _ = noArgs ":reload" - -setContextAfterLoad [] = setContext prel -setContextAfterLoad (m:_) = do - cmstate <- getCmState - b <- io (cmModuleIsInterpreted cmstate m) - if b then setContext ('*':m) else setContext m - -modulesLoadedMsg ok mods dflags = + io (revertCAFs) -- always revert CAFs on reload. + session <- getSession + ok <- io (GHC.load session LoadAllTargets) + afterLoad ok session +reloadModule m = do + io (revertCAFs) -- always revert CAFs on reload. + session <- getSession + ok <- io (GHC.load session (LoadUpTo (mkModule m))) + afterLoad ok session + +afterLoad ok session = do + io (revertCAFs) -- always revert CAFs on load. + graph <- io (GHC.getModuleGraph session) + graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph + setContextAfterLoad session graph' + modulesLoadedMsg ok (map GHC.ms_mod graph') + +setContextAfterLoad session [] = do + io (GHC.setContext session [] [prelude_mod]) +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 + dflags <- getDynFlags when (verbosity dflags > 0) $ do let mod_commas | null mods = text "none." | otherwise = hsep ( - punctuate comma (map text mods)) <> text "." + punctuate comma (map pprModule mods)) <> text "." case ok of Failed -> io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) @@ -742,19 +756,22 @@ modulesLoadedMsg ok mods dflags = typeOfExpr :: String -> GHCi () typeOfExpr str - = do cms <- getCmState - maybe_tystr <- io (cmTypeOfExpr cms str) - case maybe_tystr of - Nothing -> return () - Just tystr -> io (putStrLn tystr) + = do cms <- getSession + maybe_ty <- io (GHC.exprType cms str) + case maybe_ty of + Nothing -> return () + Just ty -> do ty' <- cleanType ty + tystr <- showForUser (ppr ty') + io (putStrLn (str ++ " :: " ++ tystr)) kindOfType :: String -> GHCi () kindOfType str - = do cms <- getCmState - maybe_tystr <- io (cmKindOfType cms str) - case maybe_tystr of + = do cms <- getSession + maybe_ty <- io (GHC.typeKind cms str) + case maybe_ty of Nothing -> return () - Just tystr -> io (putStrLn tystr) + Just ty -> do tystr <- showForUser (ppr ty) + io (putStrLn (str ++ " :: " ++ tystr)) quit :: String -> GHCi Bool quit _ = return True @@ -763,6 +780,117 @@ shellEscape :: String -> GHCi Bool shellEscape str = io (system str >> return False) ----------------------------------------------------------------------------- +-- create tags file for currently loaded modules. + +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 + +ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi () +ghciCreateTagsFile kind file = do + session <- getSession + io $ createTagsFile session kind file + +-- ToDo: +-- - remove restriction that all modules must be interpreted +-- (problem: we don't know source locations for entities unless +-- we compiled the module. +-- +-- - extract createTagsFile so it can be used from the command-line +-- (probably need to fix first problem before this is useful). +-- +createTagsFile :: Session -> TagsKind -> FilePath -> IO () +createTagsFile session tagskind tagFile = do + graph <- GHC.getModuleGraph session + let ms = map GHC.ms_mod graph + tagModule m = do + is_interpreted <- GHC.moduleIsInterpreted session m + -- should we just skip these? + when (not is_interpreted) $ + throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted")) + + mbModInfo <- GHC.getModuleInfo session m + let unqual + | Just modinfo <- mbModInfo, + Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual + | otherwise = GHC.alwaysQualify + + case mbModInfo of + Just modInfo -> return $! listTags unqual modInfo + _ -> return [] + + mtags <- mapM tagModule ms + either_res <- collateAndWriteTags tagskind tagFile $ concat mtags + case either_res of + Left e -> hPutStrLn stderr $ ioeGetErrorString e + Right _ -> return () + +listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo] +listTags unqual modInfo = + [ tagInfo unqual name loc + | name <- GHC.modInfoExports modInfo + , let loc = nameSrcLoc name + , isGoodSrcLoc loc + ] + +type TagInfo = (String -- tag name + ,String -- file name + ,Int -- line number + ,Int -- column number + ) + +-- get tag info, for later translation into Vim or Emacs style +tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo +tagInfo unqual name loc + = ( showSDocForUser unqual $ pprOccName (nameOccName name) + , showSDocForUser unqual $ ftext (srcLocFile loc) + , srcLocLine loc + , srcLocCol loc + ) + +collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ()) +collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al + let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos + IO.try (writeFile file tags) +collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs + let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2 + groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos + tagGroups <- mapM tagFileGroup groups + IO.try (writeFile file $ concat tagGroups) + where + tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??") + tagFileGroup group@((_,fileName,_,_):_) = do + file <- readFile fileName -- need to get additional info from sources.. + let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2 + sortedGroup = sortLe byLine group + tags = unlines $ perFile sortedGroup 1 0 $ lines file + return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags + perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count = + perFile (tagInfo:tags) (count+1) (pos+length line) lines + perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count = + showETag tagInfo line pos : perFile tags count pos lines + perFile tags count pos lines = [] + +-- simple ctags format, for Vim et al +showTag :: TagInfo -> String +showTag (tag,file,lineNo,colNo) + = tag ++ "\t" ++ file ++ "\t" ++ show lineNo + +-- etags format, for Emacs/XEmacs +showETag :: TagInfo -> String -> Int -> String +showETag (tag,file,lineNo,colNo) line charPos + = take colNo line ++ tag + ++ "\x7f" ++ tag + ++ "\x01" ++ show lineNo + ++ "," ++ show charPos + +----------------------------------------------------------------------------- -- Browsing a module's contents browseCmd :: String -> GHCi () @@ -773,26 +901,41 @@ browseCmd m = _ -> throwDyn (CmdLineError "syntax: :browse ") browseModule m exports_only = do - cms <- getCmState + s <- getSession - is_interpreted <- io (cmModuleIsInterpreted cms m) + let modl = mkModule m + is_interpreted <- io (GHC.moduleIsInterpreted s modl) when (not is_interpreted && not exports_only) $ throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified - (as,bs) <- io (cmGetContext cms) - cms1 <- io (if exports_only then cmSetContext cms [] [prel,m] - else cmSetContext cms [m] []) - cms2 <- io (cmSetContext cms1 as bs) - - things <- io (cmBrowseModule cms2 m exports_only) - - let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context + (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) + + 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) + + filtered = filterOutChildren names + + things <- io $ mapM (GHC.lookupName s) filtered - io (putStrLn (showSDocForUser unqual ( - vcat (map (showDecl (const True)) things) - ))) + 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 @@ -810,47 +953,46 @@ setContext str sensible m = looksLikeModuleName m newContext mods = do - cms <- getCmState - (as,bs) <- separate cms mods [] [] - let bs' = if null as && prel `notElem` bs then prel:bs else bs - cms' <- io (cmSetContext cms as bs') - setCmState cms' - -separate cmstate [] as bs = return (as,bs) -separate cmstate (('*':m):ms) as bs = do - b <- io (cmModuleIsInterpreted cmstate m) - if b then separate cmstate ms (m:as) bs + session <- getSession + (as,bs) <- separate session mods [] [] + let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs + io (GHC.setContext session as bs') + +separate :: Session -> [String] -> [Module] -> [Module] + -> GHCi ([Module],[Module]) +separate session [] as bs = return (as,bs) +separate session (('*':m):ms) as bs = do + let modl = mkModule m + b <- io (GHC.moduleIsInterpreted session modl) + if b then separate session ms (modl:as) bs else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) -separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs) +separate session (m:ms) as bs = separate session ms as (mkModule m:bs) -prel = "Prelude" +prelude_mod = mkModule "Prelude" addToContext mods = do - cms <- getCmState - (as,bs) <- io (cmGetContext cms) + cms <- getSession + (as,bs) <- io (GHC.getContext cms) (as',bs') <- separate cms mods [] [] let as_to_add = as' \\ (as ++ bs) bs_to_add = bs' \\ (as ++ bs) - cms' <- io (cmSetContext cms - (as ++ as_to_add) (bs ++ bs_to_add)) - setCmState cms' + io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add)) removeFromContext mods = do - cms <- getCmState - (as,bs) <- io (cmGetContext cms) + cms <- getSession + (as,bs) <- io (GHC.getContext cms) (as_to_remove,bs_to_remove) <- separate cms mods [] [] let as' = as \\ (as_to_remove ++ bs_to_remove) bs' = bs \\ (as_to_remove ++ bs_to_remove) - cms' <- io (cmSetContext cms as' bs') - setCmState cms' + io (GHC.setContext cms as' bs') ---------------------------------------------------------------------------- -- Code for `:set' @@ -893,29 +1035,19 @@ setOptions wds = let (plus_opts, minus_opts) = partition isPlus wds mapM_ setOpt plus_opts - -- now, the GHC flags - pkgs_before <- io (readIORef v_ExplicitPackages) - leftovers <- io (processArgs static_flags minus_opts []) - pkgs_after <- io (readIORef v_ExplicitPackages) - - -- update things if the users wants more packages - let new_packages = pkgs_after \\ pkgs_before - when (not (null new_packages)) $ - newPackages new_packages - - -- don't forget about the extra command-line flags from the - -- extra_ghc_opts fields in the new packages - new_package_details <- io (getPackageDetails new_packages) - let pkg_extra_opts = concatMap extra_ghc_opts new_package_details - pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts []) - -- then, dynamic flags - io $ do - restoreDynFlags - leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) [] - saveDynFlags - - if (not (null leftovers)) + dflags <- getDynFlags + (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts + setDynFlags dflags' + + -- update things if the users wants more packages +{- TODO: + let new_packages = pkgs_after \\ pkgs_before + when (not (null new_packages)) $ + newPackages new_packages +-} + + if (not (null leftovers)) then throwDyn (CmdLineError ("unrecognised flags: " ++ unwords leftovers)) else return () @@ -966,13 +1098,15 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" +{- ToDo newPackages new_pkgs = do -- The new packages are already in v_Packages - state <- getGHCiState - cmstate1 <- io (cmUnload (cmstate state)) - setGHCiState state{ cmstate = cmstate1, targets = [] } - dflags <- io getDynFlags + session <- getSession + io (GHC.setTargets session []) + io (GHC.load session Nothing) + dflags <- getDynFlags io (linkPackages dflags new_pkgs) setContextAfterLoad [] +-} -- --------------------------------------------------------------------------- -- code for `:show' @@ -985,32 +1119,32 @@ showCmd str = _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") showModules = do - cms <- getCmState - let (mg, hpt) = cmGetModInfo cms - mapM_ (showModule hpt) mg - - -showModule :: HomePackageTable -> ModSummary -> GHCi () -showModule hpt mod_summary - = case lookupModuleEnv hpt mod of - Nothing -> panic "missing linkable" - Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn)) - where - obj_linkable = isObjectLinkable (hm_linkable mod_info) - where - mod = ms_mod mod_summary - locn = ms_location mod_summary + session <- getSession + let show_one ms = do m <- io (GHC.showModule session ms) + io (putStrLn m) + graph <- io (GHC.getModuleGraph session) + mapM_ show_one graph showBindings = do - cms <- getCmState - let - unqual = cmGetPrintUnqual cms --- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b))) - showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b))) - - io (mapM_ showBinding (cmGetBindings cms)) + s <- getSession + unqual <- io (GHC.getPrintUnqual s) + bindings <- io (GHC.getBindings s) + mapM_ showTyThing bindings return () +showTyThing (AnId id) = do + ty' <- cleanType (GHC.idType id) + str <- showForUser (ppr id <> text " :: " <> ppr ty') + io (putStrLn str) +showTyThing _ = 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 + then return ty + else return $! GHC.dropForAlls ty ----------------------------------------------------------------------------- -- GHCi monad @@ -1019,8 +1153,7 @@ data GHCiState = GHCiState { progname :: String, args :: [String], - targets :: [FilePath], - cmstate :: CmState, + session :: GHC.Session, options :: [GHCiOption] } @@ -1047,8 +1180,14 @@ getGHCiState = GHCi $ \r -> readIORef r setGHCiState s = GHCi $ \r -> writeIORef r s -- for convenience... -getCmState = getGHCiState >>= return . cmstate -setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms} +getSession = getGHCiState >>= return . session + +getDynFlags = do + s <- getSession + io (GHC.getSessionDynFlags s) +setDynFlags dflags = do + s <- getSession + io (GHC.setSessionDynFlags s dflags) isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt