-- The GHC interface
import qualified GHC
-import GHC ( Session, verbosity, dopt, DynFlag(..),
+import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
+ TargetId(..),
mkModule, pprModule, Type, Module, SuccessFlag(..),
TyThing(..), Name, LoadHowMuch(..), Phase,
GhcException(..), showGhcException,
import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
-- Other random utilities
+import Digraph ( flattenSCCs )
import BasicTypes ( failed, successIf )
import Panic ( panic, installSignalHandlers )
import Config
import Linker ( showLinkerState )
import Util ( removeSpaces, handle, global, toArgs,
looksLikeModuleName, prefixMatch, sortLe )
-import ErrUtils ( printErrorsAndWarnings )
#ifndef mingw32_HOST_OS
import System.Posix
("check", keepGoing checkModule),
("set", keepGoing setCmd),
("show", keepGoing showCmd),
- ("tags", keepGoing createTagsFileCmd),
+ ("etags", keepGoing createETagsFileCmd),
+ ("ctags", keepGoing createCTagsFileCmd),
("type", keepGoing typeOfExpr),
("kind", keepGoing kindOfType),
("unset", keepGoing unsetOptions),
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\n" ++
- " :tags -e|-c create tags file for Vi (-c) or Emacs (-e)\n" ++
+ " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
+ " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
" :type <expr> show the type of <expr>\n" ++
" :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
Readline.initialize
#endif
-#if defined(mingw32_HOST_OS)
- -- 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.
- --
- GHC.ConsoleHandler.flushConsole stdin
-#endif
startGHCi (runGHCi srcs maybe_expr)
GHCiState{ progname = "<interactive>",
args = [],
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
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
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
-- handler must be recursive, in case showing the exception causes
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
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt
case result of
- GHC.RunFailed -> return []
+ GHC.RunFailed -> return Nothing
GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
- GHC.RunOk names -> return names
+ 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
session <- getSession
- when b (mapM_ (showTypeOfName session) names)
+ case mb_names of
+ Nothing -> return ()
+ Just names -> when b (mapM_ (showTypeOfName session) names)
flushInterpBuffers
io installSignalHandlers
io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
io (GHC.setTargets session [])
io (GHC.load session LoadAllTargets)
- setContextAfterLoad []
+ setContextAfterLoad session []
io (GHC.workingDirectoryChanged session)
dir <- expandPath dir
io (setCurrentDirectory dir)
checkModule m = do
let modl = mkModule m
session <- getSession
- result <- io (GHC.checkModule session modl printErrorsAndWarnings)
+ result <- io (GHC.checkModule session modl)
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
afterLoad ok session = do
io (revertCAFs) -- always revert CAFs on load.
graph <- io (GHC.getModuleGraph session)
- let mods = map GHC.ms_mod graph
- mods' <- filterM (io . GHC.isLoaded session) mods
- setContextAfterLoad mods'
- modulesLoadedMsg ok mods'
+ graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
+ setContextAfterLoad session graph'
+ modulesLoadedMsg ok (map GHC.ms_mod graph')
-setContextAfterLoad [] = do
- session <- getSession
+setContextAfterLoad session [] = do
io (GHC.setContext session [] [prelude_mod])
-setContextAfterLoad (m:_) = do
- session <- getSession
- b <- io (GHC.moduleIsInterpreted session m)
- if b then io (GHC.setContext session [m] [])
- else io (GHC.setContext session [] [m])
+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
-----------------------------------------------------------------------------
-- create tags file for currently loaded modules.
-createTagsFileCmd :: String -> GHCi ()
-createTagsFileCmd "-c" = ghciCreateTagsFile CTags "tags"
-createTagsFileCmd "-e" = ghciCreateTagsFile ETags "TAGS"
-createTagsFileCmd _ = throwDyn (CmdLineError "syntax: :tags -c|-e")
+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
projects / ghc-hetmet.git / blobdiff