X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=d8f291c9eca33200a096d293167d65e32f5fa683;hb=05afb7485eea44d6410139f8a20c94b6f66c46f2;hp=5801a3859d0fe10d6d1fb3f9651a4576f929a807;hpb=dc813469cfae2d6ae2defe44bf014faf3ded2b32;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 5801a38..d8f291c 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ -{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} +{-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.139 2002/12/12 13:21:46 ross Exp $ +-- $Id: InteractiveUI.hs,v 1.155 2003/07/02 14:59:07 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -8,7 +8,7 @@ -- ----------------------------------------------------------------------------- module InteractiveUI ( - interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO () + interactiveUI, -- :: CmState -> [FilePath] -> IO () ghciWelcomeMsg ) where @@ -17,19 +17,19 @@ module InteractiveUI ( import CompManager import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, - isObjectLinkable ) + isObjectLinkable, GhciMode(..) ) import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) ) import MkIface ( ifaceTyThing ) import DriverFlags import DriverState -import DriverUtil ( remove_spaces, handle ) -import Linker ( initLinker, showLinkerState, linkLibraries ) -import Finder ( flushFinderCache ) +import DriverUtil ( remove_spaces ) +import Linker ( showLinkerState, linkPackages ) import Util -import Id ( isRecordSelector, recordSelectorFieldLabel, - isDataConWrapId, isDataConId, idName ) +import IdInfo ( GlobalIdDetails(..) ) +import Id ( isImplicitId, idName, globalIdDetails ) import Class ( className ) import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) ) +import DataCon ( dataConName ) import FieldLabel ( fieldLabelTyCon ) import SrcLoc ( isGoodSrcLoc ) import Module ( showModMsg, lookupModuleEnv ) @@ -41,11 +41,15 @@ import Packages import Outputable import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset ) -import Panic ( GhcException(..), showGhcException ) +import Panic hiding ( showException ) import Config -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS import System.Posix +import DriverUtil( handle ) +#if __GLASGOW_HASKELL__ > 504 + hiding (getEnv) +#endif #endif #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS @@ -71,11 +75,9 @@ import Control.Monad as Monad import GHC.Exts ( unsafeCoerce# ) -import Foreign ( nullPtr ) -import Foreign.C.String ( CString, peekCString, withCString ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import GHC.Posix ( setNonBlockingFD ) +import System.Posix.Internals ( setNonBlockingFD ) ----------------------------------------------------------------------------- @@ -90,14 +92,14 @@ GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)]) builtin_commands :: [(String, String -> GHCi Bool)] builtin_commands = [ - ("add", keepGoing addModule), + ("add", keepGoingPaths addModule), ("browse", keepGoing browseCmd), ("cd", keepGoing changeDirectory), ("def", keepGoing defineMacro), ("help", keepGoing help), ("?", keepGoing help), ("info", keepGoing info), - ("load", keepGoing loadModule), + ("load", keepGoingPaths loadModule), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), ("set", keepGoing setCmd), @@ -111,6 +113,9 @@ builtin_commands = [ keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False +keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) +keepGoingPaths a str = a (toArgs str) >> return False + shortHelpText = "use :? for help.\n" -- NOTE: spaces at the end of each line to workaround CPP/string gap bug. @@ -150,16 +155,14 @@ helpText = "\ \ (eg. -v2, -fglasgow-exts, etc.)\n\ \" -interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO () -interactiveUI cmstate paths cmdline_objs = do - hFlush stdout - hSetBuffering stdout NoBuffering - +interactiveUI :: [FilePath] -> IO () +interactiveUI srcs = do dflags <- getDynFlags - -- packages are loaded "on-demand" now - initLinker - linkLibraries dflags cmdline_objs + cmstate <- cmInit Interactive; + + hFlush stdout + hSetBuffering stdout NoBuffering -- Initialise buffering for the *interpreted* I/O system cmstate <- initInterpBuffering cmstate dflags @@ -175,10 +178,10 @@ interactiveUI cmstate paths cmdline_objs = do Readline.initialize #endif - startGHCi (runGHCi paths dflags) + startGHCi (runGHCi srcs dflags) GHCiState{ progname = "", args = [], - targets = paths, + targets = srcs, cmstate = cmstate, options = [] } @@ -221,14 +224,14 @@ runGHCi paths dflags = do Left e -> return () Right hdl -> fileLoop hdl False - -- perform a :load for files given on the GHCi command line + -- Perform a :load for files given on the GHCi command line when (not (null paths)) $ ghciHandle showException $ - loadModule (unwords paths) + loadModule paths -- enter the interactive loop -#if defined(mingw32_TARGET_OS) - -- always show prompt, since hIsTerminalDevice returns True for Consoles +#if defined(mingw32_HOST_OS) + -- Always show prompt, since hIsTerminalDevice returns True for Consoles -- only, which we may or may not be running under (cf. Emacs sub-shells.) interactiveLoop True #else @@ -241,7 +244,7 @@ runGHCi paths dflags = do interactiveLoop is_tty = do - -- ignore ^C exceptions caught here + -- Ignore ^C exceptions caught here ghciHandleDyn (\e -> case e of Interrupted -> ghciUnblock (interactiveLoop is_tty) _other -> return ()) $ do @@ -267,7 +270,7 @@ interactiveLoop is_tty = do checkPerms :: String -> IO Bool checkPerms name = -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS return True #else DriverUtil.handle (\_ -> return False) $ do @@ -349,6 +352,7 @@ runCommand c = ghciHandle handler (doCommand c) handler :: Exception -> GHCi Bool handler exception = do flushInterpBuffers + io installSignalHandlers ghciHandle handler (showException exception >> return False) showException (DynException dyn) = @@ -390,6 +394,7 @@ finishEvalExpr names when b (mapM_ (showTypeOfName cmstate) names) flushInterpBuffers + io installSignalHandlers b <- isOptionSet RevertCAFs io (when b revertCAFs) return True @@ -489,11 +494,13 @@ info s = do | fix == defaultFixity = empty | otherwise = ppr fix <+> (if isSymOcc (nameOccName name) - then ppr name - else char '`' <> ppr name <> char '`') + then ppr name + else char '`' <> ppr name <> char '`') showTyThing (AClass cl) = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] + showTyThing (ADataCon dc) + = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)] showTyThing (ATyCon ty) | isPrimTyCon ty = hcat [ppr ty, text " is a primitive type constructor"] @@ -503,13 +510,10 @@ info s = do = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)] idDescr id - | isRecordSelector id = - case tyConClass_maybe (fieldLabelTyCon ( - recordSelectorFieldLabel id)) of - Nothing -> text "record selector" - Just c -> text "method in class " <> ppr c - | isDataConWrapId id = text "data constructor" - | otherwise = text "variable" + = case globalIdDetails id of + RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl) + ClassOpId cls -> text "method in class" <+> ppr cls + otherwise -> text "variable" -- also print out the source location for home things showSrcLoc name @@ -523,12 +527,12 @@ info s = do setCmState cms return () -addModule :: String -> GHCi () -addModule str = do - let files = words str +addModule :: [FilePath] -> GHCi () +addModule files = do state <- getGHCiState dflags <- io (getDynFlags) io (revertCAFs) -- always revert CAFs on load/add. + files <- mapM expandPath files let new_targets = files ++ targets state graph <- io (cmDepAnal (cmstate state) dflags new_targets) (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph) @@ -537,10 +541,9 @@ addModule str = do modulesLoadedMsg ok mods dflags changeDirectory :: String -> GHCi () -changeDirectory ('~':d) = do - tilde <- io (getEnv "HOME") -- will fail if HOME not defined - io (setCurrentDirectory (tilde ++ '/':d)) -changeDirectory d = io (setCurrentDirectory d) +changeDirectory dir = do + dir <- expandPath dir + io (setCurrentDirectory dir) defineMacro :: String -> GHCi () defineMacro s = do @@ -587,14 +590,17 @@ undefineMacro macro_name = do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) -loadModule :: String -> GHCi () -loadModule str = timeIt (loadModule' str) +loadModule :: [FilePath] -> GHCi () +loadModule fs = timeIt (loadModule' fs) -loadModule' str = do - let files = words str +loadModule' :: [FilePath] -> GHCi () +loadModule' files = do state <- getGHCiState dflags <- io getDynFlags + -- 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) dflags files) @@ -699,8 +705,9 @@ browseModule m exports_only = do things' = filter wantToSee things - wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id) - wantToSee _ = True + wantToSee (AnId id) = not (isImplicitId id) + wantToSee (ADataCon _) = False -- They'll come via their TyCon + wantToSee _ = True thing_names = map getName things @@ -833,9 +840,9 @@ setOptions wds = mapM_ setOpt plus_opts -- now, the GHC flags - pkgs_before <- io (readIORef v_Packages) + pkgs_before <- io (readIORef v_ExplicitPackages) leftovers <- io (processArgs static_flags minus_opts []) - pkgs_after <- io (readIORef v_Packages) + pkgs_after <- io (readIORef v_ExplicitPackages) -- update things if the users wants more packages let new_packages = pkgs_after \\ pkgs_before @@ -910,9 +917,10 @@ newPackages new_pkgs = do -- The new packages are already in v_Packages dflags <- io getDynFlags cmstate1 <- io (cmUnload (cmstate state) dflags) setGHCiState state{ cmstate = cmstate1, targets = [] } + io (linkPackages dflags new_pkgs) setContextAfterLoad [] ------------------------------------------------------------------------------ +-- --------------------------------------------------------------------------- -- code for `:show' showCmd str = @@ -1058,3 +1066,15 @@ revertCAFs = do foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- Make it "safe", just in case + +-- ----------------------------------------------------------------------------- +-- Utils + +expandPath :: String -> GHCi String +expandPath path = + case dropWhile isSpace path of + ('~':d) -> do + tilde <- io (getEnv "HOME") -- will fail if HOME not defined + return (tilde ++ '/':d) + other -> + return other