X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=42f6b1b535d37efcfc4fda7b9c2409e96272c6b6;hb=6b4e00e082b0f4f2445fabbfacae730576adfa2c;hp=1648773984c8e151b3cd84d2b2b72175fcdaa667;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 1648773..42f6b1b 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.176 2004/09/30 10:36:47 simonpj Exp $ +-- $Id: InteractiveUI.hs,v 1.190 2005/02/23 15:38:52 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -12,29 +12,25 @@ module 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 HscTypes ( GhciMode(..) ) +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), + IfaceConDecl(..), IfaceType, + IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, + pprIfaceForAllPart, pprIfaceType ) 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 Name ( Name, NamedThing(..) ) import OccName ( OccName, isSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) ) -import Packages +import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) import Outputable -import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, - restoreDynFlags, dopt_unset ) +import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) import Panic hiding ( showException ) import Config import SrcLoc ( SrcLoc, isGoodSrcLoc ) @@ -47,7 +43,7 @@ import System.Posix #endif #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,7 +52,7 @@ 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 @@ -64,13 +60,16 @@ import Data.Int ( Int64 ) 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 ) @@ -154,9 +153,8 @@ helpText = " (eg. -v2, -fglasgow-exts, etc.)\n" -interactiveUI :: [FilePath] -> Maybe String -> IO () -interactiveUI srcs maybe_expr = do - dflags <- getDynFlags +interactiveUI :: DynFlags -> [FilePath] -> Maybe String -> IO () +interactiveUI dflags srcs maybe_expr = do cmstate <- cmInit Interactive dflags; @@ -185,7 +183,7 @@ interactiveUI srcs maybe_expr = do -- initial context is just the Prelude cmstate <- cmSetContext cmstate [] ["Prelude"] -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE Readline.initialize #endif @@ -196,7 +194,7 @@ interactiveUI srcs maybe_expr = do cmstate = cmstate, options = [] } -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE Readline.resetTerminal Nothing #endif @@ -251,7 +249,7 @@ runGHCi paths dflags maybe_expr = do interactiveLoop is_tty show_prompt Just expr -> do -- just evaluate the expression we were given - runCommand expr + runCommandEval expr return () -- and finally, exit @@ -265,7 +263,7 @@ interactiveLoop is_tty show_prompt = do _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 @@ -312,8 +310,14 @@ fileLoop hdl prompt = do 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 "" -> fileLoop hdl prompt @@ -331,7 +335,7 @@ stringLoop (s:ss) = do mkPrompt toplevs exports = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> " -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE readlineLoop :: GHCi () readlineLoop = do cmstate <- getCmState @@ -355,6 +359,15 @@ readlineLoop = do runCommand :: String -> GHCi Bool runCommand c = ghciHandle handler (doCommand c) +-- 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)) + -- 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 @@ -391,16 +404,14 @@ runStmt stmt | null (filter (not.isSpace) stmt) = return [] | otherwise = do st <- getGHCiState - dflags <- io getDynFlags - let cm_state' = cmSetDFlags (cmstate st) - (dopt_unset dflags Opt_WarnUnusedBinds) + cmstate <- getCmState (new_cmstate, result) <- io $ withProgName (progname st) $ withArgs (args st) $ - cmRunStmt cm_state' stmt + cmRunStmt cmstate stmt setGHCiState st{cmstate = new_cmstate} case result of CmRunFailed -> return [] - CmRunException e -> showException e >> return [] + CmRunException e -> throw e -- this is caught by runCommand(Eval) CmRunOk names -> return names -- possibly print the type and revert CAFs after evaluating an expression @@ -446,9 +457,9 @@ 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 @@ -488,18 +499,19 @@ info :: String -> GHCi () info "" = throwDyn (CmdLineError "syntax: ':i '") info s = do { let names = words s ; init_cms <- getCmState - ; mapM_ (infoThing init_cms) names } + ; dflags <- getDynFlags + ; let exts = dopt Opt_GlasgowExts dflags + ; mapM_ (infoThing exts init_cms) names } where - infoThing cms name + infoThing exts cms name = do { stuff <- io (cmGetInfo cms name) ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $ - vcat (intersperse (text "") (map showThing stuff)))) } + vcat (intersperse (text "") (map (showThing exts) stuff)))) } -showThing :: GetInfoResult -> SDoc -showThing (wanted_str, (thing, fixity, src_loc, insts)) - = vcat [ showDecl want_name thing, +showThing :: Bool -> GetInfoResult -> SDoc +showThing exts (wanted_str, (thing, fixity, src_loc, insts)) + = vcat [ showWithLoc src_loc (showDecl exts want_name thing), show_fixity fixity, - show_loc src_loc, vcat (map show_inst insts)] where want_name occ = wanted_str == occNameUserString occ @@ -508,31 +520,35 @@ showThing (wanted_str, (thing, fixity, src_loc, insts)) | fix == defaultFixity = empty | otherwise = ppr fix <+> text wanted_str + show_inst (iface_inst, loc) + = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst)) + +showWithLoc :: SrcLoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> show_loc loc) + -- The tab tries to make them line up a bit + where 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}) +showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc +showDecl exts 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 exts want_name (IfaceId {ifName = var, ifType = ty}) + = ppr var <+> dcolon <+> showType exts ty -showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_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 want_name (IfaceData {ifName = tycon, +showDecl exts want_name (IfaceData {ifName = tycon, ifTyVars = tyvars, ifCons = condecls}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 2 (add_bars (ppr_trim show_con cs)) @@ -579,15 +595,21 @@ showDecl want_name (IfaceData {ifName = tycon, ppr_str MarkedUnboxed = ptext SLIT("!!") ppr_str NotMarkedStrict = empty -showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, +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 <+> 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 + | want_name clas || want_name op + = Just (ppr_bndr op <+> dcolon <+> showType exts ty) + | otherwise + = Nothing + +showType :: Bool -> IfaceType -> SDoc +showType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls +showType False ty = ppr ty -- otherwise, print without the foralls ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] ppr_trim show xs @@ -617,7 +639,7 @@ addModule files = do (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate = cmstate1, targets = new_targets } setContextAfterLoad mods - dflags <- io getDynFlags + dflags <- getDynFlags modulesLoadedMsg ok mods dflags changeDirectory :: String -> GHCi () @@ -697,7 +719,7 @@ loadModule' files = do setGHCiState state{ cmstate = cmstate2, targets = files } setContextAfterLoad mods - dflags <- io (getDynFlags) + dflags <- getDynFlags modulesLoadedMsg ok mods dflags @@ -716,7 +738,7 @@ reloadModule "" = do <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate=cmstate1 } setContextAfterLoad mods - dflags <- io getDynFlags + dflags <- getDynFlags modulesLoadedMsg ok mods dflags reloadModule _ = noArgs ":reload" @@ -790,8 +812,10 @@ browseModule m exports_only = do let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context + dflags <- getDynFlags + let exts = dopt Opt_GlasgowExts dflags io (putStrLn (showSDocForUser unqual ( - vcat (map (showDecl (const True)) things) + vcat (map (showDecl exts (const True)) things) ))) ----------------------------------------------------------------------------- @@ -894,28 +918,21 @@ setOptions 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 []) + leftovers <- io $ processStaticFlags minus_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 $ processDynamicFlags leftovers dflags + 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 () @@ -970,7 +987,7 @@ 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 + dflags <- getDynFlags io (linkPackages dflags new_pkgs) setContextAfterLoad [] @@ -984,22 +1001,10 @@ showCmd str = ["linker"] -> io showLinkerState _ -> 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 +showModules + = do { cms <- getCmState + ; let show_one ms = io (putStrLn (cmShowModule cms ms)) + ; mapM_ show_one (cmGetModuleGraph cms) } showBindings = do cms <- getCmState @@ -1050,6 +1055,10 @@ setGHCiState s = GHCi $ \r -> writeIORef r s getCmState = getGHCiState >>= return . cmstate setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms} +getDynFlags = getCmState >>= return . cmGetDFlags + +setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags) + isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt = do st <- getGHCiState