diff options
| -rw-r--r-- | compiler/main/GHC.hs | 2 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 10 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 55 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 2 | ||||
| -rw-r--r-- | docs/users_guide/ghci.xml | 8 | ||||
| -rw-r--r-- | ghc/GhciMonad.hs | 6 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 103 |
8 files changed, 124 insertions, 64 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 99362cd308..ae2dedfed3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -98,7 +98,7 @@ module GHC ( typeKind, parseName, RunResult(..), - runStmt, SingleStep(..), + runStmt, parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index b1832504f9..76c35ea1e6 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -14,7 +14,7 @@ module HscMain , hscSimplify , hscNormalIface, hscWriteIface, hscGenHardCode #ifdef GHCI - , hscStmt, hscTcExpr, hscKcType + , hscStmt, hscTcExpr, hscImport, hscKcType , compileExpr #endif , HsCompiler(..) @@ -51,7 +51,7 @@ import PrelNames ( iNTERACTIVE ) import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan ) +import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc ) import VarSet import VarEnv ( emptyTidyEnv ) #endif @@ -931,6 +931,12 @@ hscStmt hsc_env stmt = do return $ Just (ids, hval) +hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName) +hscImport hsc_env str = do + (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str + case is of + [i] -> return (unLoc i) + _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration"))) hscTcExpr -- Typecheck an expression (but don't run it) :: GhcMonad m => diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index dbad1fbe2e..d5ded92905 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1125,7 +1125,7 @@ data InteractiveContext ic_toplev_scope :: [Module], -- ^ The context includes the "top-level" scope of -- these modules - ic_exports :: [Module], -- ^ The context includes just the exports of these + ic_exports :: [(Module, Maybe (ImportDecl RdrName))], -- ^ The context includes just the exported parts of these -- modules ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The contexts' cached 'GlobalRdrEnv', built from diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 7e4406e61b..db1fd418c6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -9,7 +9,7 @@ module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, SingleStep(..), + runStmt, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, @@ -40,9 +40,11 @@ module InteractiveEval ( #include "HsVersions.h" import HscMain hiding (compileExpr) +import HsSyn (ImportDecl) import HscTypes import TcRnDriver -import RnNames ( gresFromAvails ) +import TcRnMonad (initTc) +import RnNames (gresFromAvails, rnImports) import InstEnv import Type import TcType hiding( typeKind ) @@ -51,6 +53,7 @@ import Id import Name hiding ( varName ) import NameSet import RdrName +import PrelNames (pRELUDE) import VarSet import VarEnv import ByteCodeInstr @@ -74,7 +77,7 @@ import MonadUtils import System.Directory import Data.Dynamic -import Data.List (find) +import Data.List (find, partition) import Control.Monad import Foreign import Foreign.C @@ -251,6 +254,8 @@ withVirtualCWD m = do gbracket set_cwd reset_cwd $ \_ -> m +parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) +parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 @@ -790,21 +795,31 @@ fromListBL bound l = BL (length l) bound l [] -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. setContext :: GhcMonad m => - [Module] -- ^ entire top level scope of these modules - -> [Module] -- ^ exports only of these modules - -> m () -setContext toplev_mods export_mods = do - hsc_env <- getSession - let old_ic = hsc_IC hsc_env - hpt = hsc_HPT hsc_env - -- - export_env <- liftIO $ mkExportEnv hsc_env export_mods - toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - modifySession $ \_ -> - hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = export_mods, - ic_rn_gbl_env = all_env }} + [Module] -- ^ entire top level scope of these modules + -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules + -> m () +setContext toplev_mods other_mods = do + hsc_env <- getSession + let old_ic = hsc_IC hsc_env + hpt = hsc_HPT hsc_env + (decls,mods) = partition (isJust . snd) other_mods -- time for tracing + export_mods = map fst mods + imprt_decls = map noLoc (catMaybes (map snd decls)) + -- + export_env <- liftIO $ mkExportEnv hsc_env export_mods + import_env <- + if null imprt_decls then return emptyGlobalRdrEnv else do + let imports = rnImports imprt_decls + this_mod = if null toplev_mods then pRELUDE else head toplev_mods + (_, env, _,_) <- + ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports + return env + toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods + let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs + modifySession $ \_ -> + hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, + ic_exports = other_mods, + ic_rn_gbl_env = all_env }} -- Make a GlobalRdrEnv based on the exports of the modules only. mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv @@ -841,7 +856,7 @@ mkTopLevEnv hpt modl -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. -getContext :: GhcMonad m => m ([Module],[Module]) +getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))]) getContext = withSession $ \HscEnv{ hsc_IC=ic } -> return (ic_toplev_scope ic, ic_exports ic) @@ -965,7 +980,7 @@ dynCompileExpr expr = do setContext full $ (mkModule (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ):exports + ,Nothing):exports let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" Just (ids, hvals) <- withSession (flip hscStmt stmt) setContext full exports diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 649807e0e7..069446fb43 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1341,7 +1341,7 @@ getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) getModuleExports hsc_env mod = let ic = hsc_IC hsc_env - checkMods = ic_toplev_scope ic ++ ic_exports ic + checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic) in initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index 6e54ace778..1ff5ffd4cb 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -589,10 +589,12 @@ hello Prelude IO> </screen> - <para>(Note: you can use <literal>import M</literal> as an - alternative to <literal>:module +M</literal>, and + <para>(Note: you can use conventional + haskell <literal>import</literal> syntax as + well, but this does not support + <literal>*</literal> forms). <literal>:module</literal> can also be shortened to - <literal>:m</literal>). The full syntax of the + <literal>:m</literal>. The full syntax of the <literal>:module</literal> command is:</para> <screen> diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 94bd9c2576..88c8caa06d 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -69,7 +69,7 @@ data GHCiState = GHCiState -- remember is here: last_command :: Maybe Command, cmdqueue :: [String], - remembered_ctx :: [(CtxtCmd, [String], [String])], + remembered_ctx :: [Either (CtxtCmd, [String], [String]) String], -- we remember the :module commands between :loads, so that -- on a :reload we can replay them. See bugs #2049, -- \#1873, #1360. Previously we tried to remember modules that @@ -257,6 +257,10 @@ runStmt expr step = do return GHC.RunFailed) $ do GHC.runStmt expr step +parseImportDecl :: GhcMonad m => String -> m (Maybe (GHC.ImportDecl GHC.RdrName)) +parseImportDecl expr + = GHC.handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return Nothing) (Monad.liftM Just (GHC.parseImportDecl expr)) + resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult resume canLogSpan step = do st <- getGHCiState diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 42246b204e..a62e10d059 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -33,7 +33,9 @@ import Packages import UniqFM import HscTypes ( handleFlagWarnings ) +import HsImpExp import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? +import RdrName (RdrName) import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv import Name @@ -337,7 +339,7 @@ interactiveUI srcs maybe_exprs = do -- initial context is just the Prelude prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing - GHC.setContext [] [prel_mod] + GHC.setContext [] [(prel_mod, Nothing)] default_editor <- liftIO $ findEditor @@ -541,15 +543,13 @@ mkPrompt = do dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty - - modules_bit = -- ToDo: maybe... -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+> -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+> hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> - hsep (map (ppr . GHC.moduleName) exports) + hsep (map (ppr . GHC.moduleName) (nub (map fst exports))) deflt_prompt = dots <> context_bit <> modules_bit @@ -644,7 +644,7 @@ enqueueCommands cmds = do runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step | null (filter (not.isSpace) stmt) = return False - | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod) + | x@('i':'m':'p':'o':'r':'t':' ':_) <- stmt = keepGoing' (importContext True) x | otherwise = do #if __GLASGOW_HASKELL__ >= 611 @@ -1005,6 +1005,9 @@ cmdCmd str = do enqueueCommands (lines cmds) return () +loadModuleName :: GHC.GhcMonad m => ImportDecl RdrName -> m Module +loadModuleName = flip GHC.findModule Nothing . unLoc . ideclName + loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) @@ -1061,7 +1064,7 @@ reloadModule m = do else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag +doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag doLoad retain_context prev_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. @@ -1070,7 +1073,7 @@ doLoad retain_context prev_context howmuch = do afterLoad ok retain_context prev_context return ok -afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi () +afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi () afterLoad ok retain_context prev_context = do lift revertCAFs -- always revert CAFs on load. lift discardTickArrays @@ -1082,10 +1085,10 @@ afterLoad ok retain_context prev_context = do lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries -setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi () setContextAfterLoad prev keep_ctxt [] = do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod]) + setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)]) setContextAfterLoad prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets @@ -1113,24 +1116,28 @@ setContextAfterLoad prev keep_ctxt ms = do if b then setContextKeepingPackageModules prev keep_ctxt ([m], []) else do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m]) + setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)]) -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules - :: ([Module],[Module]) -- previous context + :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context -> Bool -- re-execute :module commands - -> ([Module],[Module]) -- new context + -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context -> GHCi () setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do let (_,bs0) = prev_context prel_mod <- getPrelude - let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0 - let bs1 = if null as then nub (prel_mod : bs) else bs - GHC.setContext as (nub (bs1 ++ pkg_modules)) + -- filter everything, not just lefts + let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0 + let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs + GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules)) if keep_ctxt then do st <- getGHCiState - mapM_ (playCtxtCmd False) (remembered_ctx st) + let mem = remembered_ctx st + playCmd (Left x) = playCtxtCmd False x + playCmd (Right x) = importContext False x + mapM_ playCmd mem else do st <- getGHCiState setGHCiState st{ remembered_ctx = [] } @@ -1138,6 +1145,9 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId +sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool +sameFst x y = fst x == fst y + modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags @@ -1192,8 +1202,8 @@ browseCmd bang m = -- recently-added module occurs last, it seems. case (as,bs) of (as@(_:_), _) -> browseModule bang (last as) True - ([], bs@(_:_)) -> browseModule bang (last bs) True - ([], []) -> ghcError (CmdLineError ":browse: no current module") + ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True + ([], []) -> ghcError (CmdLineError ":browse: no current module") _ -> ghcError (CmdLineError "syntax: :browse <module>") -- without bang, show items in context of their parents and omit children @@ -1208,7 +1218,7 @@ browseModule bang modl exports_only = do -- just so we can get an appropriate PrintUnqualified (as,bs) <- GHC.getContext prel_mod <- lift getPrelude - if exports_only then GHC.setContext [] [prel_mod,modl] + if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)] else GHC.setContext [modl] [] target_unqual <- GHC.getPrintUnqual GHC.setContext as bs @@ -1284,12 +1294,30 @@ browseModule bang modl exports_only = do ----------------------------------------------------------------------------- -- Setting the module context +importContext :: Bool -> String -> GHCi () +importContext fail str + = do + (as,bs) <- GHC.getContext + x <- do_checks fail + case Monad.join x of + Nothing -> return () + (Just a) -> do + m <- loadModuleName a + GHC.setContext as (bs++[(m,Just a)]) + st <- getGHCiState + let cmds = remembered_ctx st + setGHCiState st{ remembered_ctx = cmds++[Right str] } + where + do_checks True = liftM Just (GhciMonad.parseImportDecl str) + do_checks False = trymaybe (GhciMonad.parseImportDecl str) + setContext :: String -> GHCi () setContext str | all sensible strs = do playCtxtCmd True (cmd, as, bs) st <- getGHCiState - setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } + let cmds = remembered_ctx st + setGHCiState st{ remembered_ctx = cmds ++ [Left (cmd,as,bs)] } | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where (cmd, strs, as, bs) = @@ -1317,33 +1345,38 @@ playCtxtCmd fail (cmd, as, bs) case cmd of SetContext -> do prel_mod <- getPrelude - let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs' + let bs'' = if null as && prel_mod `notElem` (map fst bs') then (prel_mod,Nothing):bs' else bs' - return (as',bs'') + return (as', bs'') AddModules -> do - let as_to_add = as' \\ (prev_as ++ prev_bs) - bs_to_add = bs' \\ (prev_as ++ prev_bs) - return (prev_as ++ as_to_add, prev_bs ++ bs_to_add) + -- it should replace the old stuff, not the other way around + -- need deleteAllBy, not deleteFirstsBy for sameFst + let remaining_as = prev_as \\ (as' ++ map fst bs') + remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as') + return (remaining_as ++ as', remaining_bs ++ bs') RemModules -> do - let new_as = prev_as \\ (as' ++ bs') - new_bs = prev_bs \\ (as' ++ bs') + let new_as = prev_as \\ (as' ++ map fst bs') + new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs') return (new_as, new_bs) GHC.setContext new_as new_bs where do_checks True = do as' <- mapM wantInterpretedModule as bs' <- mapM lookupModule bs - return (as',bs') + return (as', map contextualize bs') do_checks False = do as' <- mapM (trymaybe . wantInterpretedModule) as bs' <- mapM (trymaybe . lookupModule) bs - return (catMaybes as', catMaybes bs') - - trymaybe m = do - r <- ghciTry m - case r of - Left _ -> return Nothing - Right a -> return (Just a) + return (catMaybes as', map contextualize (catMaybes bs')) + contextualize x = (x,Nothing) + deleteAllBy f a b = filter (\x->(not (any (f x) b))) a + +trymaybe ::GHCi a -> GHCi (Maybe a) +trymaybe m = do + r <- ghciTry m + case r of + Left _ -> return Nothing + Right a -> return (Just a) ---------------------------------------------------------------------------- -- Code for `:set' |