-- The GHC interface
import qualified GHC
-import GHC ( Session, verbosity, dopt, DynFlag(..),
- mkModule, pprModule, Type, Module, SuccessFlag(..),
- TyThing(..), Name, LoadHowMuch(..),
+import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
+ TargetId(..), DynFlags(..),
+ pprModule, Type, Module, SuccessFlag(..),
+ TyThing(..), Name, LoadHowMuch(..), Phase,
GhcException(..), showGhcException,
- CheckedModule(..) )
+ CheckedModule(..), SrcLoc )
+import DynFlags ( allFlags )
+import Packages ( PackageState(..) )
+import PackageConfig ( InstalledPackageInfo(..) )
+import UniqFM ( eltsUFM )
+import PprTyThing
import Outputable
--- following all needed for :info... ToDo: remove
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
- IfaceConDecl(..), IfaceType,
- pprIfaceDeclHead, pprParendIfaceType,
- pprIfaceForAllPart, pprIfaceType )
-import FunDeps ( pprFundeps )
-import SrcLoc ( SrcLoc, pprDefnLoc )
-import OccName ( OccName, parenSymOcc, occNameUserString )
-import BasicTypes ( StrictnessMark(..), defaultFixity, failed, successIf )
+-- for createtags (should these come via GHC?)
+import Module ( moduleString )
+import Name ( nameSrcLoc, nameModule, nameOccName )
+import OccName ( pprOccName )
+import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
-- Other random utilities
+import Digraph ( flattenSCCs )
+import BasicTypes ( failed, successIf )
import Panic ( panic, installSignalHandlers )
import Config
import StaticFlags ( opt_IgnoreDotGhci )
import Linker ( showLinkerState )
import Util ( removeSpaces, handle, global, toArgs,
- looksLikeModuleName, prefixMatch )
-import ErrUtils ( printErrorsAndWarnings )
+ looksLikeModuleName, prefixMatch, sortLe )
#ifndef mingw32_HOST_OS
-import Util ( handle )
import System.Posix
#if __GLASGOW_HASKELL__ > 504
hiding (getEnv)
import Numeric
import Data.List
import Data.Int ( Int64 )
-import Data.Maybe ( isJust )
+import Data.Maybe ( isJust, fromMaybe, catMaybes )
import System.Cmd
import System.CPUTime
import System.Environment
import Data.Char
import Control.Monad as Monad
import Foreign.StablePtr ( newStablePtr )
+import Text.Printf
import GHC.Exts ( unsafeCoerce# )
import GHC.IOBase ( IOErrorType(InvalidArgument) )
"/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
"\\____/\\/ /_/\\____/|_| Type :? for help.\n"
-GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
+type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
+cmdName (n,_,_,_) = n
-builtin_commands :: [(String, String -> GHCi Bool)]
+GLOBAL_VAR(commands, builtin_commands, [Command])
+
+builtin_commands :: [Command]
builtin_commands = [
- ("add", keepGoingPaths addModule),
- ("browse", keepGoing browseCmd),
- ("cd", keepGoing changeDirectory),
- ("def", keepGoing defineMacro),
- ("help", keepGoing help),
- ("?", keepGoing help),
- ("info", keepGoing info),
- ("load", keepGoingPaths loadModule_),
- ("module", keepGoing setContext),
- ("reload", keepGoing reloadModule),
- ("check", keepGoing checkModule),
- ("set", keepGoing setCmd),
- ("show", keepGoing showCmd),
- ("type", keepGoing typeOfExpr),
- ("kind", keepGoing kindOfType),
- ("unset", keepGoing unsetOptions),
- ("undef", keepGoing undefineMacro),
- ("quit", quit)
+ ("add", keepGoingPaths addModule, False, completeFilename),
+ ("browse", keepGoing browseCmd, False, completeModule),
+ ("cd", keepGoing changeDirectory, False, completeFilename),
+ ("def", keepGoing defineMacro, False, completeIdentifier),
+ ("help", keepGoing help, False, completeNone),
+ ("?", keepGoing help, False, completeNone),
+ ("info", keepGoing info, False, completeIdentifier),
+ ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
+ ("module", keepGoing setContext, False, completeModule),
+ ("main", keepGoing runMain, False, completeIdentifier),
+ ("reload", keepGoing reloadModule, False, completeNone),
+ ("check", keepGoing checkModule, False, completeHomeModule),
+ ("set", keepGoing setCmd, True, completeSetOptions),
+ ("show", keepGoing showCmd, False, completeNone),
+ ("etags", keepGoing createETagsFileCmd, False, completeFilename),
+ ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
+ ("type", keepGoing typeOfExpr, False, completeIdentifier),
+ ("kind", keepGoing kindOfType, False, completeIdentifier),
+ ("unset", keepGoing unsetOptions, True, completeSetOptions),
+ ("undef", keepGoing undefineMacro, False, completeMacro),
+ ("quit", quit, False, completeNone)
]
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
" :info [<name> ...] display information about the given names\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
+ " :main [<arguments> ...] run the main function with the given arguments\n" ++
" :reload reload the current module set\n" ++
"\n" ++
" :set <option> ... set options\n" ++
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\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" ++
" (eg. -v2, -fglasgow-exts, etc.)\n"
-interactiveUI :: Session -> [FilePath] -> Maybe String -> IO ()
+interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
-- HACK! If we happen to get into an infinite loop (eg the user
#ifdef USE_READLINE
Readline.initialize
-#endif
+ Readline.setAttemptedCompletionFunction (Just completeWord)
+ --Readline.parseAndBind "set show-all-if-ambiguous 1"
-#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
+ let symbols = "!#$%&*+/<=>?@\\^|-~"
+ specials = "(),;[]`{}"
+ spaces = " \t\n"
+ word_break_chars = spaces ++ specials ++ symbols
+
+ Readline.setBasicWordBreakCharacters word_break_chars
+ Readline.setCompleterWordBreakCharacters word_break_chars
#endif
+
startGHCi (runGHCi srcs maybe_expr)
GHCiState{ progname = "<interactive>",
args = [],
return ()
-runGHCi :: [FilePath] -> Maybe String -> GHCi ()
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
runGHCi paths maybe_expr = do
let read_dot_files = not opt_IgnoreDotGhci
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
io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
-interactiveLoop is_tty show_prompt = do
+interactiveLoop is_tty show_prompt =
-- Ignore ^C exceptions caught here
ghciHandleDyn (\e -> case e of
- Interrupted -> ghciUnblock (
+ Interrupted -> do
#if defined(mingw32_HOST_OS)
- io (putStrLn "") >>
+ io (putStrLn "")
#endif
- interactiveLoop is_tty show_prompt)
- _other -> return ()) $ do
+ interactiveLoop is_tty show_prompt
+ _other -> return ()) $
+
+ ghciUnblock $ do -- unblock necessary if we recursed from the
+ -- exception handler above.
-- read commands from stdin
#ifdef USE_READLINE
session <- getSession
(mod,imports) <- io (GHC.getContext session)
io yield
+ saveSession -- for use by completion
l <- io (readline (mkPrompt mod imports)
`finally` setNonBlockingFD 0)
-- readline sometimes puts stdin into blocking mode,
-- so we need to put it back for the IO library
+ splatSavedSession
case l of
Nothing -> return ()
Just l ->
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
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
let (cmd,rest) = break isSpace str
- cmds <- io (readIORef commands)
- case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
- [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
+ maybe_cmd <- io (lookupCommand cmd)
+ case maybe_cmd of
+ Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
++ shortHelpText) >> return False)
- [(_,f)] -> f (dropWhile isSpace rest)
- cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
- " matches multiple commands (" ++
- foldr1 (\a b -> a ++ ',':b) (map fst cs)
- ++ ")") >> return False)
-
-noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
-
+ Just (_,f,_,_) -> f (dropWhile isSpace rest)
+
+lookupCommand :: String -> IO (Maybe Command)
+lookupCommand str = do
+ cmds <- readIORef commands
+ -- look for exact match first, then the first prefix match
+ case [ c | c <- cmds, str == cmdName c ] of
+ c:_ -> return (Just c)
+ [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
+ [] -> return Nothing
+ c:_ -> return (Just c)
-----------------------------------------------------------------------------
-- To flush buffers for the *interpreted* computation we need
; let exts = dopt Opt_GlasgowExts dflags
; mapM_ (infoThing exts session) names }
where
- infoThing exts session name
- = do { stuff <- io (GHC.getInfo session name)
- ; unqual <- io (GHC.getPrintUnqual session)
- ; io (putStrLn (showSDocForUser unqual $
- vcat (intersperse (text "") (map (showThing exts) stuff)))) }
-
-showThing :: Bool -> GHC.GetInfoResult -> SDoc
-showThing exts (wanted_str, thing, fixity, src_loc, insts)
- = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
- show_fixity fixity,
- vcat (map show_inst insts)]
+ infoThing exts session str = io $ do
+ names <- GHC.parseName session str
+ let filtered = filterOutChildren names
+ mb_stuffs <- mapM (GHC.getInfo session) filtered
+ unqual <- GHC.getPrintUnqual session
+ putStrLn (showSDocForUser unqual $
+ vcat (intersperse (text "") $
+ [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
+
+ -- Filter out names whose parent is also there Good
+ -- example is '[]', which is both a type and data
+ -- constructor in the same type
+filterOutChildren :: [Name] -> [Name]
+filterOutChildren names = filter (not . parent_is_there) names
+ where parent_is_there n
+ | Just p <- GHC.nameParent_maybe n = p `elem` names
+ | otherwise = False
+
+pprInfo exts (thing, fixity, insts)
+ = pprTyThingInContextLoc exts thing
+ $$ show_fixity fixity
+ $$ vcat (map GHC.pprInstance insts)
where
- want_name occ = wanted_str == occNameUserString occ
-
show_fixity fix
- | fix == defaultFixity = empty
- | otherwise = ppr fix <+> text wanted_str
-
- show_inst (inst_ty, loc)
- = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
-
-showWithLoc :: SrcLoc -> SDoc -> SDoc
-showWithLoc loc doc
- = hang doc 2 (char '\t' <> comment <+> pprDefnLoc loc)
- -- The tab tries to make them line up a bit
- where
- comment = ptext SLIT("--")
-
-
--- 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 :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
-showDecl exts want_name (IfaceForeign {ifName = tc})
- = ppr tc <+> ptext SLIT("is a foreign type")
-
-showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
- = ppr var <+> dcolon <+> showIfaceType exts 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 exts want_name (IfaceData {ifName = tycon,
- ifTyVars = tyvars, ifCons = condecls, ifCtxt = context})
- = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 2 (add_bars (ppr_trim show_con cs))
- where
- show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
- ifConStricts = strs, ifConFields = flds})
- | want_name tycon || want_name con_name || any want_name flds
- = Just (show_guts con_name is_infix tys_w_strs flds)
- | otherwise = Nothing
- where
- tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
- show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
- ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
- | want_name tycon || want_name con_name
- = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
- | otherwise = Nothing
- where
- tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
- pp_tau = foldr add pp_res_ty tys_w_strs
- pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
- add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
-
- show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
- show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
- show_guts con _ tys flds
- = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
- where
- show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
- = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
- | otherwise = Nothing
-
- (pp_nd, cs) = case condecls of
- IfAbstractTyCon -> (ptext SLIT("data"), [])
- IfDataTyCon cs -> (ptext SLIT("data"), cs)
- IfNewTyCon c -> (ptext SLIT("newtype"),[c])
-
- add_bars [] = empty
- add_bars [c] = equals <+> c
- add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
-
- ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
- ppr_str MarkedStrict = char '!'
- ppr_str MarkedUnboxed = ptext SLIT("!!")
- ppr_str NotMarkedStrict = empty
-
-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 <+> opt_where)
- 2 (vcat (ppr_trim show_op sigs))
- where
- opt_where | null sigs = empty
- | otherwise = ptext SLIT("where")
- show_op (IfaceClassOp op dm ty)
- | want_name clas || want_name op
- = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
- | otherwise
- = Nothing
-
-showIfaceType :: Bool -> IfaceType -> SDoc
-showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
-showIfaceType False ty = ppr ty -- otherwise, print without the foralls
-
-ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
-ppr_trim show xs
- = snd (foldr go (False, []) xs)
- where
- go x (eliding, so_far)
- | Just doc <- show x = (False, doc : so_far)
- | otherwise = if eliding then (True, so_far)
- else (True, ptext SLIT("...") : so_far)
-
-ppr_bndr :: OccName -> SDoc
--- Wrap operators in ()
-ppr_bndr occ = parenSymOcc occ (ppr occ)
-
+ | fix == GHC.defaultFixity = empty
+ | otherwise = ppr fix <+> ppr (GHC.getName thing)
-----------------------------------------------------------------------------
-- Commands
+runMain :: String -> GHCi ()
+runMain args = do
+ let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
+ runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
+ return ()
+
addModule :: [FilePath] -> GHCi ()
addModule files = do
io (revertCAFs) -- always revert CAFs on load/add.
files <- mapM expandPath files
- targets <- mapM (io . GHC.guessTarget) files
+ targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
session <- getSession
io (mapM_ (GHC.addTarget session) targets)
ok <- io (GHC.load session LoadAllTargets)
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)
if (null macro_name)
then throwDyn (CmdLineError "invalid macro name")
else do
- if (macro_name `elem` map fst cmds)
+ if (macro_name `elem` map cmdName cmds)
then throwDyn (CmdLineError
("command '" ++ macro_name ++ "' is already defined"))
else do
case maybe_hv of
Nothing -> return ()
Just hv -> io (writeIORef commands --
- ((macro_name, keepGoing (runMacro hv)) : cmds))
+ (cmds ++ [(macro_name, keepGoing (runMacro hv), False, completeNone)]))
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
runMacro fun s = do
undefineMacro :: String -> GHCi ()
undefineMacro macro_name = do
cmds <- io (readIORef commands)
- if (macro_name `elem` map fst builtin_commands)
+ if (macro_name `elem` map cmdName builtin_commands)
then throwDyn (CmdLineError
("command '" ++ macro_name ++ "' cannot be undefined"))
else do
- if (macro_name `notElem` map fst cmds)
+ if (macro_name `notElem` map cmdName cmds)
then throwDyn (CmdLineError
("command '" ++ macro_name ++ "' not defined"))
else do
- io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
+ io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
-loadModule :: [FilePath] -> GHCi SuccessFlag
+loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule fs = timeIt (loadModule' fs)
loadModule_ :: [FilePath] -> GHCi ()
-loadModule_ fs = do loadModule fs; return ()
+loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
-loadModule' :: [FilePath] -> GHCi SuccessFlag
+loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule' files = do
session <- getSession
io (GHC.load session LoadAllTargets)
-- expand tildes
- files <- mapM expandPath files
- targets <- io (mapM GHC.guessTarget files)
+ let (filenames, phases) = unzip files
+ exp_filenames <- mapM expandPath filenames
+ let files' = zip exp_filenames phases
+ targets <- io (mapM (uncurry GHC.guessTarget) files')
-- NOTE: we used to do the dependency anal first, so that if it
-- fails we didn't throw away the current set of modules. This would
checkModule :: String -> GHCi ()
checkModule m = do
- let modl = mkModule m
+ let modl = GHC.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 (
(local,global) = partition ((== modl) . GHC.nameModule) scope
in
(text "global names: " <+> ppr global) $$
- text "local names: " <+> ppr local))
- _ -> empty
+ (text "local names: " <+> ppr local)
+ _ -> empty))
afterLoad (successIf (isJust result)) session
reloadModule :: String -> GHCi ()
reloadModule m = do
io (revertCAFs) -- always revert CAFs on reload.
session <- getSession
- ok <- io (GHC.load session (LoadUpTo (mkModule m)))
+ ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
afterLoad ok session
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
shellEscape str = io (system str >> return False)
-----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+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
+
+ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
+ghciCreateTagsFile kind file = do
+ session <- getSession
+ io $ createTagsFile session kind file
+
+-- ToDo:
+-- - remove restriction that all modules must be interpreted
+-- (problem: we don't know source locations for entities unless
+-- we compiled the module.
+--
+-- - extract createTagsFile so it can be used from the command-line
+-- (probably need to fix first problem before this is useful).
+--
+createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
+createTagsFile session tagskind tagFile = do
+ graph <- GHC.getModuleGraph session
+ let ms = map GHC.ms_mod graph
+ tagModule m = do
+ is_interpreted <- GHC.moduleIsInterpreted session m
+ -- should we just skip these?
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
+
+ mbModInfo <- GHC.getModuleInfo session m
+ let unqual
+ | Just modinfo <- mbModInfo,
+ Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
+ | otherwise = GHC.alwaysQualify
+
+ case mbModInfo of
+ Just modInfo -> return $! listTags unqual modInfo
+ _ -> return []
+
+ mtags <- mapM tagModule ms
+ either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
+ case either_res of
+ Left e -> hPutStrLn stderr $ ioeGetErrorString e
+ Right _ -> return ()
+
+listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
+listTags unqual modInfo =
+ [ tagInfo unqual name loc
+ | name <- GHC.modInfoExports modInfo
+ , let loc = nameSrcLoc name
+ , isGoodSrcLoc loc
+ ]
+
+type TagInfo = (String -- tag name
+ ,String -- file name
+ ,Int -- line number
+ ,Int -- column number
+ )
+
+-- get tag info, for later translation into Vim or Emacs style
+tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
+tagInfo unqual name loc
+ = ( showSDocForUser unqual $ pprOccName (nameOccName name)
+ , showSDocForUser unqual $ ftext (srcLocFile loc)
+ , srcLocLine loc
+ , srcLocCol loc
+ )
+
+collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
+collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
+ let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
+ IO.try (writeFile file tags)
+collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
+ let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
+ groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
+ tagGroups <- mapM tagFileGroup groups
+ IO.try (writeFile file $ concat tagGroups)
+ where
+ tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
+ tagFileGroup group@((_,fileName,_,_):_) = do
+ file <- readFile fileName -- need to get additional info from sources..
+ let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
+ sortedGroup = sortLe byLine group
+ tags = unlines $ perFile sortedGroup 1 0 $ lines file
+ return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
+ perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
+ perFile (tagInfo:tags) (count+1) (pos+length line) lines
+ perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
+ showETag tagInfo line pos : perFile tags count pos lines
+ perFile tags count pos lines = []
+
+-- simple ctags format, for Vim et al
+showTag :: TagInfo -> String
+showTag (tag,file,lineNo,colNo)
+ = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
+
+-- etags format, for Emacs/XEmacs
+showETag :: TagInfo -> String -> Int -> String
+showETag (tag,file,lineNo,colNo) line charPos
+ = take colNo line ++ tag
+ ++ "\x7f" ++ tag
+ ++ "\x01" ++ show lineNo
+ ++ "," ++ show charPos
+
+-----------------------------------------------------------------------------
-- Browsing a module's contents
browseCmd :: String -> GHCi ()
browseModule m exports_only = do
s <- getSession
- let modl = mkModule m
+ let modl = GHC.mkModule m
is_interpreted <- io (GHC.moduleIsInterpreted s modl)
when (not is_interpreted && not exports_only) $
throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
(as,bs) <- io (GHC.getContext s)
io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
else GHC.setContext s [modl] [])
+ unqual <- io (GHC.getPrintUnqual s)
io (GHC.setContext s as bs)
- things <- io (GHC.browseModule s modl exports_only)
- unqual <- io (GHC.getPrintUnqual s)
+ mb_mod_info <- io $ GHC.getModuleInfo s modl
+ case mb_mod_info of
+ Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
+ Just mod_info -> do
+ let names
+ | exports_only = GHC.modInfoExports mod_info
+ | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
- dflags <- getDynFlags
- let exts = dopt Opt_GlasgowExts dflags
- io (putStrLn (showSDocForUser unqual (
- vcat (map (showDecl exts (const True)) things)
- )))
+ filtered = filterOutChildren names
+
+ things <- io $ mapM (GHC.lookupName s) filtered
+
+ dflags <- getDynFlags
+ let exts = dopt Opt_GlasgowExts dflags
+ io (putStrLn (showSDocForUser unqual (
+ vcat (map (pprTyThingInContext exts) (catMaybes things))
+ )))
+ -- ToDo: modInfoInstances currently throws an exception for
+ -- package modules. When it works, we can do this:
+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
-----------------------------------------------------------------------------
-- Setting the module context
-> GHCi ([Module],[Module])
separate session [] as bs = return (as,bs)
separate session (('*':m):ms) as bs = do
- let modl = mkModule m
+ let modl = GHC.mkModule m
b <- io (GHC.moduleIsInterpreted session modl)
if b then separate session ms (modl:as) bs
else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
-separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
+separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
-prelude_mod = mkModule "Prelude"
+prelude_mod = GHC.mkModule "Prelude"
addToContext mods = do
then return ty
else return $! GHC.dropForAlls ty
+-- -----------------------------------------------------------------------------
+-- Completion
+
+#ifdef USE_READLINE
+completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
+completeWord w start end = do
+ line <- Readline.getLineBuffer
+ case w of
+ ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
+ _other
+ | Just c <- is_cmd line -> do
+ maybe_cmd <- lookupCommand c
+ let (n,w') = selectWord (words' 0 line)
+ case maybe_cmd of
+ Nothing -> return Nothing
+ Just (_,_,False,complete) -> wrapCompleter complete w
+ Just (_,_,True,complete) -> let complete' w = do rets <- complete w
+ return (map (drop n) rets)
+ in wrapCompleter complete' w'
+ | otherwise -> do
+ --printf "complete %s, start = %d, end = %d\n" w start end
+ wrapCompleter completeIdentifier w
+ where words' _ [] = []
+ words' n str = let (w,r) = break isSpace str
+ (s,r') = span isSpace r
+ in (n,w):words' (n+length w+length s) r'
+ -- In a Haskell expression we want to parse 'a-b' as three words
+ -- where a compiler flag (ie. -fno-monomorphism-restriction) should
+ -- only be a single word.
+ selectWord [] = (0,w)
+ selectWord ((offset,x):xs)
+ | offset+length x >= start = (start-offset,take (end-offset) x)
+ | otherwise = selectWord xs
+
+is_cmd line
+ | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
+ | otherwise = Nothing
+
+completeNone w = return []
+
+completeCmd w = do
+ cmds <- readIORef commands
+ return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
+
+completeMacro w = do
+ cmds <- readIORef commands
+ let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
+ return (filter (w `isPrefixOf`) cmds')
+
+completeIdentifier w = do
+ s <- restoreSession
+ rdrs <- GHC.getRdrNamesInScope s
+ return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
+
+completeModule w = do
+ s <- restoreSession
+ dflags <- GHC.getSessionDynFlags s
+ let pkg_mods = allExposedModules dflags
+ return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
+
+completeHomeModule w = do
+ s <- restoreSession
+ g <- GHC.getModuleGraph s
+ let home_mods = map GHC.ms_mod g
+ return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
+
+completeSetOptions w = do
+ return (filter (w `isPrefixOf`) options)
+ where options = "args":"prog":allFlags
+
+completeFilename = Readline.filenameCompletionFunction
+
+completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
+
+unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
+unionComplete f1 f2 w = do
+ s1 <- f1 w
+ s2 <- f2 w
+ return (s1 ++ s2)
+
+wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
+wrapCompleter fun w = do
+ strs <- fun w
+ case strs of
+ [] -> return Nothing
+ [x] -> return (Just (x,[]))
+ xs -> case getCommonPrefix xs of
+ "" -> return (Just ("",xs))
+ pref -> return (Just (pref,xs))
+
+getCommonPrefix :: [String] -> String
+getCommonPrefix [] = ""
+getCommonPrefix (s:ss) = foldl common s ss
+ where common s "" = s
+ common "" s = ""
+ common (c:cs) (d:ds)
+ | c == d = c : common cs ds
+ | otherwise = ""
+
+allExposedModules :: DynFlags -> [Module]
+allExposedModules dflags
+ = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
+ where
+ pkg_db = pkgIdMap (pkgState dflags)
+#endif
+
-----------------------------------------------------------------------------
-- GHCi monad
-- for convenience...
getSession = getGHCiState >>= return . session
+GLOBAL_VAR(saved_sess, no_saved_sess, Session)
+no_saved_sess = error "no saved_ses"
+saveSession = getSession >>= io . writeIORef saved_sess
+splatSavedSession = io (writeIORef saved_sess no_saved_sess)
+restoreSession = readIORef saved_sess
+
getDynFlags = do
s <- getSession
io (GHC.getSessionDynFlags s)
projects / ghc-hetmet.git / blobdiff