-{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
+{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.137 2002/10/17 14:49:52 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.158 2003/08/27 12:29:21 simonmar Exp $
--
-- GHC Interactive User Interface
--
--
-----------------------------------------------------------------------------
module InteractiveUI (
- interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
+ interactiveUI, -- :: CmState -> [FilePath] -> IO ()
ghciWelcomeMsg
) where
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 )
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
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 )
-----------------------------------------------------------------------------
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),
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.
\ (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
Readline.initialize
#endif
- startGHCi (runGHCi paths dflags)
+ startGHCi (runGHCi srcs dflags)
GHCiState{ progname = "<interactive>",
args = [],
- targets = paths,
+ targets = srcs,
cmstate = cmstate,
options = [] }
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
- -- only, which we may or may not be running under (cf. Emacs sub-shells.)
- interactiveLoop True
-#else
+ -- 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)
- interactiveLoop is_tty
-#endif
+ let show_prompt = verbosity dflags > 0 || is_tty
+
+ -- enter the interactive loop
+ interactiveLoop is_tty show_prompt
-- and finally, exit
io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
-interactiveLoop is_tty = do
- -- ignore ^C exceptions caught here
+interactiveLoop is_tty show_prompt = do
+ -- Ignore ^C exceptions caught here
ghciHandleDyn (\e -> case e of
- Interrupted -> ghciUnblock (interactiveLoop is_tty)
+ Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
_other -> return ()) $ do
-- read commands from stdin
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
if (is_tty)
then readlineLoop
- else fileLoop stdin False -- turn off prompt for non-TTY input
+ else fileLoop stdin show_prompt
#else
- fileLoop stdin is_tty
+ fileLoop stdin show_prompt
#endif
checkPerms :: String -> IO Bool
checkPerms name =
-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS
return True
#else
DriverUtil.handle (\_ -> return False) $ 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
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
when b (mapM_ (showTypeOfName cmstate) names)
flushInterpBuffers
+ io installSignalHandlers
b <- isOptionSet RevertCAFs
io (when b revertCAFs)
return True
| 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"]
= 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
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)
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
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)
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
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
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 =
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)
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
projects / ghc-hetmet.git / blobdiff