From eea143f8588519000033279518877f85180b3e0f Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 21 Jan 2008 14:59:35 +0000 Subject: [PATCH] FIX #2049, another problem with the module context on :reload The previous attempt to fix this (#1873, #1360) left a problem that occurred when the first :load of the program failed (#2049). Now I've implemented a different strategy: between :loads, we remember all the :module commands, and just replay them after a :reload. This is in addition to remembering all the package modules added with :module, which is orthogonal. This approach is simpler than the previous one, and seems to do the right thing in all the cases I could think of. Let's hope this is the last bug in this series... --- compiler/ghci/GhciMonad.hs | 15 +++- compiler/ghci/InteractiveUI.hs | 167 ++++++++++++++++++---------------------- 2 files changed, 87 insertions(+), 95 deletions(-) diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 8de9d38..e56c4de 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -68,11 +68,20 @@ data GHCiState = GHCiState -- remember is here: last_command :: Maybe Command, cmdqueue :: [String], - remembered_ctx :: Maybe ([Module],[Module]) - -- modules we want to add to the context, but can't - -- because they currently have errors. Set by :reload. + remembered_ctx :: [(CtxtCmd, [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 + -- were supposed to be in the context but currently had errors, + -- but this was complicated. Just replaying the :module commands + -- seems to be the right thing. } +data CtxtCmd + = SetContext + | AddModules + | RemModules + type TickArray = Array Int [(BreakIndex,SrcSpan)] data GHCiOption diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index afd9702..8b34e67 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -344,7 +344,7 @@ interactiveUI session srcs maybe_exprs = do tickarrays = emptyModuleEnv, last_command = Nothing, cmdqueue = [], - remembered_ctx = Nothing + remembered_ctx = [] } #ifdef USE_READLINE @@ -898,7 +898,7 @@ changeDirectory dir = do prev_context <- io $ GHC.getContext session io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) - setContextAfterLoad session prev_context [] + setContextAfterLoad session prev_context False [] io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -1080,45 +1080,14 @@ afterLoad ok session retain_context prev_context = do loaded_mod_names = map GHC.moduleName loaded_mods modulesLoadedMsg ok loaded_mod_names - st <- getGHCiState - if not retain_context - then do - setGHCiState st{ remembered_ctx = Nothing } - setContextAfterLoad session prev_context loaded_mod_summaries - else do - -- figure out which modules we can keep in the context, which we - -- have to put back, and which we have to remember because they - -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360 - let (as,bs) = prev_context - as1 = filter isHomeModule as -- package modules are kept anyway - bs1 = filter isHomeModule bs - (as_ok, as_bad) = partition (`elem` loaded_mods) as1 - (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1 - (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st) - (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as - (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs - as' = nub (as_ok++rem_as_ok) - bs' = nub (bs_ok++rem_bs_ok) - rem_as' = nub (rem_as_bad ++ as_bad) - rem_bs' = nub (rem_bs_bad ++ bs_bad) - - -- Put back into the context any modules that we previously had - -- to drop because they weren't available (rem_as_ok, rem_bs_ok). - setContextKeepingPackageModules session prev_context (as',bs') - - -- If compilation failed, remember any modules that we are unable - -- to load, so that we can put them back in the context in the future. - case ok of - Succeeded -> setGHCiState st{ remembered_ctx = Nothing } - Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') } - - - -setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi () -setContextAfterLoad session prev [] = do + setContextAfterLoad session prev_context retain_context loaded_mod_summaries + + +setContextAfterLoad :: Session -> ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad session prev keep_ctxt [] = do prel_mod <- getPrelude - setContextKeepingPackageModules session prev ([], [prel_mod]) -setContextAfterLoad session prev ms = do + setContextKeepingPackageModules session prev keep_ctxt ([], [prel_mod]) +setContextAfterLoad session prev keep_ctxt 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 @@ -1142,23 +1111,31 @@ setContextAfterLoad session prev ms = do load_this summary | m <- GHC.ms_mod summary = do b <- io (GHC.moduleIsInterpreted session m) - if b then setContextKeepingPackageModules session prev ([m], []) + if b then setContextKeepingPackageModules session prev keep_ctxt ([m], []) else do prel_mod <- getPrelude - setContextKeepingPackageModules session prev ([],[prel_mod,m]) + setContextKeepingPackageModules session prev keep_ctxt ([],[prel_mod,m]) -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules :: Session -> ([Module],[Module]) -- previous context + -> Bool -- re-execute :module commands -> ([Module],[Module]) -- new context -> GHCi () -setContextKeepingPackageModules session prev_context (as,bs) = do +setContextKeepingPackageModules session 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 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules)) + if keep_ctxt + then do + st <- getGHCiState + mapM_ (playCtxtCmd False) (remembered_ctx st) + else do + st <- getGHCiState + setGHCiState st{ remembered_ctx = [] } isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId @@ -1317,60 +1294,65 @@ browseModule bang modl exports_only = do setContext :: String -> GHCi () setContext str - | all sensible mods = fn mods + | all sensible strs = do + playCtxtCmd True (cmd, as, bs) + st <- getGHCiState + setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where - (fn, mods) = case str of - '+':stuff -> (addToContext, words stuff) - '-':stuff -> (removeFromContext, words stuff) - stuff -> (newContext, words stuff) + (cmd, strs, as, bs) = + case str of + '+':stuff -> rest AddModules stuff + '-':stuff -> rest RemModules stuff + stuff -> rest SetContext stuff + + rest cmd stuff = (cmd, strs, as, bs) + where strs = words stuff + (as,bs) = partitionWith starred strs sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m -separate :: Session -> [String] -> [Module] -> [Module] - -> GHCi ([Module],[Module]) -separate _ [] as bs = return (as,bs) -separate session (('*':str):ms) as bs = do - m <- wantInterpretedModule str - separate session ms (m:as) bs -separate session (str:ms) as bs = do - m <- lookupModule str - 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 :: [String] -> GHCi () -addToContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (new_as,new_bs) <- separate s strs [] [] + starred ('*':m) = Left m + starred m = Right m - let as_to_add = new_as \\ (as ++ bs) - bs_to_add = new_bs \\ (as ++ bs) - - io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add) - - -removeFromContext :: [String] -> GHCi () -removeFromContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (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 s as' bs' +playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi () +playCtxtCmd fail (cmd, as, bs) + = do + s <- getSession + (as',bs') <- do_checks fail + (prev_as,prev_bs) <- io $ GHC.getContext s + (new_as, new_bs) <- + case cmd of + SetContext -> do + prel_mod <- getPrelude + let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs' + else 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) + RemModules -> do + let new_as = prev_as \\ (as' ++ bs') + new_bs = prev_bs \\ (as' ++ bs') + return (new_as, new_bs) + io $ GHC.setContext s new_as new_bs + where + do_checks True = do + as' <- mapM wantInterpretedModule as + bs' <- mapM lookupModule bs + return (as',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) ---------------------------------------------------------------------------- -- Code for `:set' @@ -1502,7 +1484,7 @@ newDynFlags minus_opts = do io (GHC.load session LoadAllTargets) io (linkPackages dflags new_pkgs) -- package flags changed, we can't re-use any of the old context - setContextAfterLoad session ([],[]) [] + setContextAfterLoad session ([],[]) False [] return () @@ -1833,6 +1815,8 @@ ghciHandle h (GHCi m) = GHCi $ \s -> ghciUnblock :: GHCi a -> GHCi a ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) +ghciTry :: GHCi a -> GHCi (Either Exception a) +ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s) -- ---------------------------------------------------------------------------- -- Utils @@ -2358,4 +2342,3 @@ setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool setBreakFlag toggle array index | toggle = GHC.setBreakOn array index | otherwise = GHC.setBreakOff array index - -- 1.7.10.4