X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=e7a5a37edb9c793863fe6e09842344ae3849bdb8;hb=8099fc7e9c54b24dc50c2cd1b9bfdc59e2d218b1;hp=55384bc63e3f89c9031a62ffbdea99e0e0548959;hpb=7593fccbd8957551fff5cb052883230d555a890c;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 55384bc..e7a5a37 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -3,7 +3,7 @@ -- -- GHC Interactive User Interface -- --- (c) The GHC Team 2005 +-- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- module InteractiveUI ( @@ -17,48 +17,40 @@ module InteractiveUI ( import GHC.Exts ( Int(..), Ptr(..), int2Addr# ) import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr ) import System.IO.Unsafe ( unsafePerformIO ) -import Var ( Id, globaliseId, idName, idType ) -import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..) - , extendTypeEnvWithIds ) -import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv ) -import NameEnv ( delListFromNameEnv ) -import TcType ( tidyTopType ) -import qualified Id ( setIdType ) -import IdInfo ( GlobalIdDetails(..) ) -import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker ) -import PrelNames ( breakpointJumpName, breakpointCondJumpName ) +import Var +import HscTypes +import RdrName +import NameEnv +import TcType +import qualified Id +import IdInfo +import PrelNames #endif -- The GHC interface import qualified GHC -import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..), - TargetId(..), DynFlags(..), - pprModule, Type, Module, SuccessFlag(..), - TyThing(..), Name, LoadHowMuch(..), Phase, - GhcException(..), showGhcException, - CheckedModule(..), SrcLoc ) -import DynFlags ( allFlags ) -import Packages ( PackageState(..) ) -import PackageConfig ( InstalledPackageInfo(..) ) -import UniqFM ( eltsUFM ) +import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), + Type, Module, ModuleName, TyThing(..), Phase ) +import DynFlags +import Packages +import PackageConfig +import UniqFM import PprTyThing import Outputable --- for createtags (should these come via GHC?) -import Module ( moduleString ) -import Name ( nameSrcLoc, nameModule, nameOccName ) -import OccName ( pprOccName ) -import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) +-- for createtags +import Name +import OccName +import SrcLoc -- Other random utilities -import Digraph ( flattenSCCs ) -import BasicTypes ( failed, successIf ) -import Panic ( panic, installSignalHandlers ) +import Digraph +import BasicTypes +import Panic hiding (showException) import Config -import StaticFlags ( opt_IgnoreDotGhci ) -import Linker ( showLinkerState ) -import Util ( removeSpaces, handle, global, toArgs, - looksLikeModuleName, prefixMatch, sortLe ) +import StaticFlags +import Linker +import Util #ifndef mingw32_HOST_OS import System.Posix @@ -68,6 +60,7 @@ import System.Posix #else import GHC.ConsoleHandler ( flushConsole ) import System.Win32 ( setConsoleCP, setConsoleOutputCP ) +import qualified System.Win32 #endif #ifdef USE_READLINE @@ -78,15 +71,13 @@ import System.Console.Readline as Readline --import SystemExts import Control.Exception as Exception -import Data.Dynamic -- import Control.Concurrent import Numeric import Data.List import Data.Int ( Int64 ) -import Data.Maybe ( isJust, fromMaybe, catMaybes ) +import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes ) import System.Cmd -import System.CPUTime import System.Environment import System.Exit ( exitWith, ExitCode(..) ) import System.Directory @@ -95,7 +86,6 @@ import System.IO.Error as IO import Data.Char import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) -import Text.Printf import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) @@ -124,6 +114,9 @@ builtin_commands = [ ("browse", keepGoing browseCmd, False, completeModule), ("cd", keepGoing changeDirectory, False, completeFilename), ("def", keepGoing defineMacro, False, completeIdentifier), + ("e", keepGoing editFile, False, completeFilename), + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("edit", keepGoing editFile, False, completeFilename), ("help", keepGoing help, False, completeNone), ("?", keepGoing help, False, completeNone), ("info", keepGoing info, False, completeIdentifier), @@ -160,6 +153,8 @@ helpText = " :browse [*] display the names defined by \n" ++ " :cd change directory to \n" ++ " :def define a command :\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ " :help, :? display this list of commands\n" ++ " :info [ ...] display information about the given names\n" ++ " :load ... load module(s) and their dependents\n" ++ @@ -171,12 +166,13 @@ helpText = " :set args ... set the arguments returned by System.getArgs\n" ++ " :set prog set the value returned by System.getProgName\n" ++ " :set prompt set the prompt used in GHCi\n" ++ + " :set editor set the command used for :edit\n" ++ "\n" ++ " :show modules show the currently loaded modules\n" ++ " :show bindings show the current bindings made at the prompt\n" ++ "\n" ++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ - " :etags [] create tags file for Emacs (defauilt: \"TAGS\")\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ " :type show the type of \n" ++ " :kind show the kind of \n" ++ " :undef undefine user-defined command :\n" ++ @@ -242,18 +238,32 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b ic_type_env = new_type_env } writeIORef ref (hsc_env { hsc_IC = new_ic }) is_tty <- hIsTerminalDevice stdin + prel_mod <- GHC.findModule session prel_name Nothing + default_editor <- findEditor withExtendedLinkEnv (zip names hValues) $ startGHCi (interactiveLoop is_tty True) GHCiState{ progname = "", args = [], prompt = location++"> ", + editor = default_editor, session = session, - options = [] } + options = [], + prelude = prel_mod } writeIORef ref hsc_env putStrLn $ "Returning to normal execution..." return b #endif +findEditor = do + getEnv "EDITOR" + `IO.catch` \_ -> do +#if mingw32_HOST_OS + win <- System.Win32.getWindowsDirectory + return (win `joinFileName` "notepad.exe") +#else + return "" +#endif + interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () interactiveUI session srcs maybe_expr = do #if defined(GHCI) && defined(BREAKPOINT) @@ -273,18 +283,23 @@ interactiveUI session srcs maybe_expr = do newStablePtr stdout newStablePtr stderr - hFlush stdout - hSetBuffering stdout NoBuffering - -- Initialise buffering for the *interpreted* I/O system initInterpBuffering session + when (isNothing maybe_expr) $ do + -- Only for GHCi (not runghc and ghc -e): + -- Turn buffering off for the compiled program's stdout/stderr + turnOffBuffering + -- Turn buffering off for GHCi's stdout + hFlush stdout + hSetBuffering stdout NoBuffering -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. - hSetBuffering stdin NoBuffering + hSetBuffering stdin NoBuffering -- initial context is just the Prelude - GHC.setContext session [] [prelude_mod] + prel_mod <- GHC.findModule session prel_name Nothing + GHC.setContext session [] [prel_mod] #ifdef USE_READLINE Readline.initialize @@ -300,12 +315,16 @@ interactiveUI session srcs maybe_expr = do Readline.setCompleterWordBreakCharacters word_break_chars #endif + default_editor <- findEditor + startGHCi (runGHCi srcs maybe_expr) GHCiState{ progname = "", args = [], prompt = "%s> ", + editor = default_editor, session = session, - options = [] } + options = [], + prelude = prel_mod } #ifdef USE_READLINE Readline.resetTerminal Nothing @@ -313,6 +332,8 @@ interactiveUI session srcs maybe_expr = do return () +prel_name = GHC.mkModuleName "Prelude" + runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () runGHCi paths maybe_expr = do let read_dot_files = not opt_IgnoreDotGhci @@ -481,8 +502,8 @@ mkPrompt toplevs exports prompt f (x:xs) = char x <> f xs f [] = empty - perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+> - hsep (map pprModule exports) + perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> + hsep (map (ppr . GHC.moduleName) exports) #ifdef USE_READLINE @@ -534,32 +555,6 @@ runCommandEval c = ghciHandle handleEval (doCommand c) -- 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 --- 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 - Nothing -> io (putStrLn ("*** Exception: (unknown)")) - Just Interrupted -> io (putStrLn "Interrupted.") - Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError - Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto - Just other_ghc_ex -> io (print other_ghc_ex) - -showException other_exception - = io (putStrLn ("*** Exception: " ++ show other_exception)) - runStmt :: String -> GHCi (Maybe [Name]) runStmt stmt | null (filter (not.isSpace) stmt) = return (Just []) @@ -594,12 +589,6 @@ showTypeOfName session n Nothing -> return () Just thing -> showTyThing thing -showForUser :: SDoc -> GHCi String -showForUser doc = do - session <- getSession - unqual <- io (GHC.getPrintUnqual session) - return $! showSDocForUser unqual doc - specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do @@ -621,45 +610,6 @@ lookupCommand str = do c:_ -> return (Just c) ----------------------------------------------------------------------------- --- To flush buffers for the *interpreted* computation we need --- to refer to *its* stdout/stderr handles - -GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) -GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) - -no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ - " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" -flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr" - -initInterpBuffering :: Session -> IO () -initInterpBuffering session - = do maybe_hval <- GHC.compileExpr session no_buf_cmd - - case maybe_hval of - Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) - other -> panic "interactiveUI:setBuffering" - - maybe_hval <- GHC.compileExpr session flush_cmd - case maybe_hval of - Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) - _ -> panic "interactiveUI:flush" - - turnOffBuffering -- Turn it off right now - - return () - - -flushInterpBuffers :: GHCi () -flushInterpBuffers - = io $ do Monad.join (readIORef flush_interp) - return () - -turnOffBuffering :: IO () -turnOffBuffering - = do Monad.join (readIORef turn_off_buffering) - return () - ------------------------------------------------------------------------------ -- Commands help :: String -> GHCi () @@ -688,7 +638,8 @@ info s = do { let names = words s 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 +-- | Just p <- GHC.nameParent_maybe n = p `elem` names +-- ToDo!! | otherwise = False pprInfo exts (thing, fixity, insts) @@ -732,6 +683,27 @@ changeDirectory dir = do dir <- expandPath dir io (setCurrentDirectory dir) +editFile :: String -> GHCi () +editFile str + | null str = do + -- find the name of the "topmost" file loaded + session <- getSession + graph0 <- io (GHC.getModuleGraph session) + graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0 + let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing) + case GHC.ml_hs_file (GHC.ms_location (last graph2)) of + Just file -> do_edit file + Nothing -> throwDyn (CmdLineError "unknown file name") + | otherwise = do_edit str + where + do_edit file = do + st <- getGHCiState + let cmd = editor st + when (null cmd) $ + throwDyn (CmdLineError "editor not set, use :set editor") + io $ system (cmd ++ ' ':file) + return () + defineMacro :: String -> GHCi () defineMacro s = do let (macro_name, definition) = break isSpace s @@ -807,16 +779,16 @@ loadModule' files = do checkModule :: String -> GHCi () checkModule m = do - let modl = GHC.mkModule m + let modl = GHC.mkModuleName m session <- getSession result <- io (GHC.checkModule session modl) case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( - case checkedModuleInfo r of + case GHC.checkedModuleInfo r of Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> let - (local,global) = partition ((== modl) . GHC.nameModule) scope + (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) @@ -832,22 +804,23 @@ reloadModule "" = do reloadModule m = do io (revertCAFs) -- always revert CAFs on reload. session <- getSession - ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m))) + ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m))) afterLoad ok session afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. graph <- io (GHC.getModuleGraph session) - graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph + graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph setContextAfterLoad session graph' - modulesLoadedMsg ok (map GHC.ms_mod graph') + modulesLoadedMsg ok (map GHC.ms_mod_name graph') #if defined(GHCI) && defined(BREAKPOINT) io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session)) ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]) #endif setContextAfterLoad session [] = do - io (GHC.setContext session [] [prelude_mod]) + prel_mod <- getPrelude + io (GHC.setContext session [] [prel_mod]) setContextAfterLoad session ms = do -- load a target if one is available, otherwise load the topmost module. targets <- io (GHC.getTargets session) @@ -864,7 +837,7 @@ setContextAfterLoad session ms = do (m:_) -> Just m summary `matches` Target (TargetModule m) _ - = GHC.ms_mod summary == m + = GHC.ms_mod_name summary == m summary `matches` Target (TargetFile f _) _ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' summary `matches` target @@ -873,17 +846,19 @@ setContextAfterLoad session ms = do 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]) + else do + prel_mod <- getPrelude + io (GHC.setContext session [] [prel_mod,m]) -modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi () +modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags when (verbosity dflags > 0) $ do let mod_commas | null mods = text "none." | otherwise = hsep ( - punctuate comma (map pprModule mods)) <> text "." + punctuate comma (map ppr mods)) <> text "." case ok of Failed -> io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) @@ -950,8 +925,9 @@ createTagsFile session tagskind tagFile = do is_interpreted <- GHC.moduleIsInterpreted session m -- should we just skip these? when (not is_interpreted) $ - throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted")) - + throwDyn (CmdLineError ("module '" + ++ GHC.moduleNameString (GHC.moduleName m) + ++ "' is not interpreted")) mbModInfo <- GHC.getModuleInfo session m let unqual | Just modinfo <- mbModInfo, @@ -1039,8 +1015,7 @@ browseCmd m = browseModule m exports_only = do s <- getSession - - let modl = GHC.mkModule m + modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing is_interpreted <- io (GHC.moduleIsInterpreted s modl) when (not is_interpreted && not exports_only) $ throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) @@ -1048,7 +1023,8 @@ browseModule m exports_only = do -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified (as,bs) <- io (GHC.getContext s) - io (if exports_only then GHC.setContext s [] [prelude_mod,modl] + prel_mod <- getPrelude + io (if exports_only then GHC.setContext s [] [prel_mod,modl] else GHC.setContext s [modl] []) unqual <- io (GHC.getPrintUnqual s) io (GHC.setContext s as bs) @@ -1089,47 +1065,53 @@ setContext str sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m -newContext mods = do - session <- getSession - (as,bs) <- separate session mods [] [] - let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs - io (GHC.setContext session as bs') - -separate :: Session -> [String] -> [Module] -> [Module] - -> GHCi ([Module],[Module]) +separate :: Session -> [String] -> [Module] -> [Module] + -> GHCi ([Module],[Module]) separate session [] as bs = return (as,bs) -separate session (('*':m):ms) as bs = do - 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 (GHC.mkModule m:bs) - -prelude_mod = GHC.mkModule "Prelude" +separate session (('*':str):ms) as bs = do + m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + b <- io $ GHC.moduleIsInterpreted session m + if b then separate session ms (m:as) bs + else throwDyn (CmdLineError ("module '" + ++ GHC.moduleNameString (GHC.moduleName m) + ++ "' is not interpreted")) +separate session (str:ms) as bs = do + m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + separate session ms as (m:bs) + +newContext :: [String] -> GHCi () +newContext strs = do + s <- getSession + (as,bs) <- separate s strs [] [] + prel_mod <- getPrelude + let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs + io $ GHC.setContext s as bs' -addToContext mods = do - cms <- getSession - (as,bs) <- io (GHC.getContext cms) +addToContext :: [String] -> GHCi () +addToContext strs = do + s <- getSession + (as,bs) <- io $ GHC.getContext s - (as',bs') <- separate cms mods [] [] + (new_as,new_bs) <- separate s strs [] [] - let as_to_add = as' \\ (as ++ bs) - bs_to_add = bs' \\ (as ++ bs) + let as_to_add = new_as \\ (as ++ bs) + bs_to_add = new_bs \\ (as ++ bs) - io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add)) + io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add) -removeFromContext mods = do - cms <- getSession - (as,bs) <- io (GHC.getContext cms) +removeFromContext :: [String] -> GHCi () +removeFromContext strs = do + s <- getSession + (as,bs) <- io $ GHC.getContext s - (as_to_remove,bs_to_remove) <- separate cms mods [] [] + (as_to_remove,bs_to_remove) <- separate s strs [] [] let as' = as \\ (as_to_remove ++ bs_to_remove) bs' = bs \\ (as_to_remove ++ bs_to_remove) - io (GHC.setContext cms as' bs') + io $ GHC.setContext s as' bs' ---------------------------------------------------------------------------- -- Code for `:set' @@ -1152,11 +1134,13 @@ setCmd "" else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) setCmd str - = case words str of + = case toArgs str of ("args":args) -> setArgs args ("prog":prog) -> setProg prog - ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str) + ("prompt":prompt) -> setPrompt (after 6) + ("editor":cmd) -> setEditor (after 6) wds -> setOptions wds + where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str setArgs args = do st <- getGHCiState @@ -1168,6 +1152,10 @@ setProg [prog] = do setProg _ = do io (hPutStrLn stderr "syntax: :set prog ") +setEditor cmd = do + st <- getGHCiState + setGHCiState st{ editor = cmd } + setPrompt value = do st <- getGHCiState if null value @@ -1184,21 +1172,28 @@ setOptions wds = -- then, dynamic flags dflags <- getDynFlags + let pkg_flags = packageFlags dflags (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts - setDynFlags dflags' - - -- update things if the users wants more packages -{- TODO: - let new_packages = pkgs_after \\ pkgs_before - when (not (null new_packages)) $ - newPackages new_packages --} if (not (null leftovers)) then throwDyn (CmdLineError ("unrecognised flags: " ++ unwords leftovers)) else return () + new_pkgs <- setDynFlags dflags' + + -- if the package flags changed, we should reset the context + -- and link the new packages. + dflags <- getDynFlags + when (packageFlags dflags /= pkg_flags) $ do + io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..." + session <- getSession + io (GHC.setTargets session []) + io (GHC.load session LoadAllTargets) + io (linkPackages dflags new_pkgs) + setContextAfterLoad session [] + return () + unsetOptions :: String -> GHCi () unsetOptions str @@ -1245,16 +1240,6 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" -{- ToDo -newPackages new_pkgs = do -- The new packages are already in v_Packages - session <- getSession - io (GHC.setTargets session []) - io (GHC.load session Nothing) - dflags <- getDynFlags - io (linkPackages dflags new_pkgs) - setContextAfterLoad [] --} - -- --------------------------------------------------------------------------- -- code for `:show' @@ -1357,7 +1342,7 @@ completeModule w = do completeHomeModule w = do s <- restoreSession g <- GHC.getModuleGraph s - let home_mods = map GHC.ms_mod g + let home_mods = map GHC.ms_mod_name g return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods)) completeSetOptions w = do @@ -1393,9 +1378,9 @@ getCommonPrefix (s:ss) = foldl common s ss | c == d = c : common cs ds | otherwise = "" -allExposedModules :: DynFlags -> [Module] +allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags - = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db)))) + = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db)))) where pkg_db = pkgIdMap (pkgState dflags) #else @@ -1409,130 +1394,6 @@ completeFilename = completeNone completeHomeModuleOrFile=completeNone #endif ------------------------------------------------------------------------------ --- GHCi monad - -data GHCiState = GHCiState - { - progname :: String, - args :: [String], - prompt :: String, - session :: GHC.Session, - options :: [GHCiOption] - } - -data GHCiOption - = ShowTiming -- show time/allocs after evaluation - | ShowType -- show the type of expressions - | RevertCAFs -- revert CAFs after every evaluation - deriving Eq - -newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } - -startGHCi :: GHCi a -> GHCiState -> IO a -startGHCi g state = do ref <- newIORef state; unGHCi g ref - -instance Monad GHCi where - (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s - return a = GHCi $ \s -> return a - -ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a -ghciHandleDyn h (GHCi m) = GHCi $ \s -> - Exception.catchDyn (m s) (\e -> unGHCi (h e) s) - -getGHCiState = GHCi $ \r -> readIORef r -setGHCiState s = GHCi $ \r -> writeIORef r s - --- 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) -setDynFlags dflags = do - s <- getSession - io (GHC.setSessionDynFlags s dflags) - -isOptionSet :: GHCiOption -> GHCi Bool -isOptionSet opt - = do st <- getGHCiState - return (opt `elem` options st) - -setOption :: GHCiOption -> GHCi () -setOption opt - = do st <- getGHCiState - setGHCiState (st{ options = opt : filter (/= opt) (options st) }) - -unsetOption :: GHCiOption -> GHCi () -unsetOption opt - = do st <- getGHCiState - setGHCiState (st{ options = filter (/= opt) (options st) }) - -io :: IO a -> GHCi a -io m = GHCi { unGHCi = \s -> m >>= return } - ------------------------------------------------------------------------------ --- recursive exception handlers - --- Don't forget to unblock async exceptions in the handler, or if we're --- in an exception loop (eg. let a = error a in a) the ^C exception --- may never be delivered. Thanks to Marcin for pointing out the bug. - -ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a -ghciHandle h (GHCi m) = GHCi $ \s -> - Exception.catch (m s) - (\e -> unGHCi (ghciUnblock (h e)) s) - -ghciUnblock :: GHCi a -> GHCi a -ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) - ------------------------------------------------------------------------------ --- timing & statistics - -timeIt :: GHCi a -> GHCi a -timeIt action - = do b <- isOptionSet ShowTiming - if not b - then action - else do allocs1 <- io $ getAllocations - time1 <- io $ getCPUTime - a <- action - allocs2 <- io $ getAllocations - time2 <- io $ getCPUTime - io $ printTimes (fromIntegral (allocs2 - allocs1)) - (time2 - time1) - return a - -foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 - -- defined in ghc/rts/Stats.c - -printTimes :: Integer -> Integer -> IO () -printTimes allocs psecs - = do let secs = (fromIntegral psecs / (10^12)) :: Float - secs_str = showFFloat (Just 2) secs - putStrLn (showSDoc ( - parens (text (secs_str "") <+> text "secs" <> comma <+> - text (show allocs) <+> text "bytes"))) - ------------------------------------------------------------------------------ --- reverting CAFs - -revertCAFs :: IO () -revertCAFs = do - rts_revertCAFs - turnOffBuffering - -- Have to turn off buffering again, because we just - -- reverted stdout, stderr & stdin to their defaults. - -foreign import ccall "revertCAFs" rts_revertCAFs :: IO () - -- Make it "safe", just in case - -- ---------------------------------------------------------------------------- -- Utils