X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=5c014beffa4035d5297226c3cfc283498478c68c;hb=49bff3215bf3fe9ada24dac2cf80f97db4e597dd;hp=686e17b40a123a6b2d4a4c90d0052fc63ed65586;hpb=3312cb5906bb61b74914663535907c7d76cdfeed;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 686e17b..5c014be 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.135 2002/10/14 14:54:16 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.157 2003/07/21 14:33:19 simonmar 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 ( flushPackageCache ) +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 ) @@ -37,14 +37,19 @@ import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, NamedThing(..) ) import OccName ( isSymOcc ) import BasicTypes ( defaultFixity, SuccessFlag(..) ) +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 DriverUtil( handle ) import System.Posix +#if __GLASGOW_HASKELL__ > 504 + hiding (getEnv) +#endif #endif #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS @@ -70,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 ) ----------------------------------------------------------------------------- @@ -89,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), @@ -110,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. @@ -149,19 +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 - -- Link in the available packages - initLinker - -- Now that demand-loading works, we don't really need to pre-load the packages - -- pkgs <- getPackages - -- linkPackages dflags pkgs - linkLibraries dflags cmdline_objs + cmstate <- cmInit Interactive; + + hFlush stdout + hSetBuffering stdout NoBuffering -- Initialise buffering for the *interpreted* I/O system cmstate <- initInterpBuffering cmstate dflags @@ -177,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 = [] } @@ -223,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 @@ -243,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 @@ -269,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 @@ -297,7 +298,7 @@ fileLoop hdl prompt = do l <- io (IO.try (hGetLine hdl)) case l of Left e | isEOFError e -> return () - | otherwise -> throw e + | otherwise -> io (ioError e) Right l -> case remove_spaces l of "" -> fileLoop hdl prompt @@ -336,16 +337,23 @@ readlineLoop = do if quit then return () else readlineLoop #endif --- Top level exception handler, just prints out the exception --- and carries on. runCommand :: String -> GHCi Bool -runCommand c = - ghciHandle ( \exception -> do - flushInterpBuffers - showException exception - return False - ) $ - doCommand c +runCommand c = ghciHandle handler (doCommand c) + +-- 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 +-- more exceptions to be raised. +-- +-- Bugfix: if the user closed stdout or stderr, the flushing will fail, +-- raising another exception. We therefore don't put the recursive +-- handler arond the flushing operation, so if stderr is closed +-- GHCi will just die gracefully rather than going into an infinite loop. +handler :: Exception -> GHCi Bool +handler exception = do + flushInterpBuffers + io installSignalHandlers + ghciHandle handler (showException exception >> return False) showException (DynException dyn) = case fromDynamic dyn of @@ -386,6 +394,7 @@ finishEvalExpr names when b (mapM_ (showTypeOfName cmstate) names) flushInterpBuffers + io installSignalHandlers b <- isOptionSet RevertCAFs io (when b revertCAFs) return True @@ -485,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"] @@ -499,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 @@ -519,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) @@ -533,10 +541,17 @@ 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 + state <- getGHCiState + when (targets state /= []) $ + io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\ + \because the search path has changed.\n" + dflags <- io getDynFlags + cmstate1 <- io (cmUnload (cmstate state) dflags) + setGHCiState state{ cmstate = cmstate1, targets = [] } + setContextAfterLoad [] + dir <- expandPath dir + io (setCurrentDirectory dir) defineMacro :: String -> GHCi () defineMacro s = do @@ -583,14 +598,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) @@ -695,8 +713,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 @@ -829,18 +848,25 @@ 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 - when (pkgs_before /= pkgs_after) $ - newPackages (pkgs_after \\ pkgs_before) + 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 [] + leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) [] saveDynFlags if (not (null leftovers)) @@ -899,13 +925,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 $ do pkgs <- getPackageInfo - flushPackageCache pkgs - + io (linkPackages dflags new_pkgs) setContextAfterLoad [] ------------------------------------------------------------------------------ +-- --------------------------------------------------------------------------- -- code for `:show' showCmd str = @@ -1008,7 +1031,7 @@ io m = GHCi { unGHCi = \s -> m >>= return } ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a ghciHandle h (GHCi m) = GHCi $ \s -> Exception.catch (m s) - (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s) + (\e -> unGHCi (ghciUnblock (h e)) s) ghciUnblock :: GHCi a -> GHCi a ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) @@ -1040,14 +1063,6 @@ printTimes allocs psecs int allocs <+> text "bytes"))) ----------------------------------------------------------------------------- --- utils - -looksLikeModuleName [] = False -looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs - -isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.' - ------------------------------------------------------------------------------ -- reverting CAFs revertCAFs :: IO () @@ -1059,3 +1074,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