X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=901dd6309849534899f91d5ecdf19f7d118904b4;hb=2ebe8addfaae2bc65e6b87ad369928b02053014f;hp=3de25ce8f0ff8237055f96d446f543aaa423ae9a;hpb=012496177fb63d96a9636cb2b151c44c30c4d572;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 3de25ce..901dd63 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -14,6 +14,7 @@ module InteractiveEval ( abandon, abandonAll, getResumeContext, getHistorySpan, + getHistoryModule, back, forward, setContext, getContext, nameSetToGlobalRdrEnv, @@ -69,6 +70,7 @@ import BasicTypes import Outputable import Data.Dynamic +import Data.List (find) import Control.Monad import Foreign import Foreign.C @@ -128,17 +130,47 @@ isStep _ = True data History = History { historyApStack :: HValue, - historyBreakInfo :: BreakInfo + historyBreakInfo :: BreakInfo, + historyEnclosingDecl :: Name + -- ^^ A cache of the enclosing declaration, for convenience } -getHistorySpan :: Session -> History -> IO SrcSpan -getHistorySpan s hist = withSession s $ \hsc_env -> do - let inf = historyBreakInfo hist +mkHistory :: HscEnv -> HValue -> BreakInfo -> History +mkHistory hsc_env hval bi = let + h = History hval bi decl + decl = findEnclosingDecl hsc_env (getHistoryModule h) + (getHistorySpan hsc_env h) + in h + +getHistoryModule :: History -> Module +getHistoryModule = breakInfo_module . historyBreakInfo + +getHistorySpan :: HscEnv -> History -> SrcSpan +getHistorySpan hsc_env hist = + let inf = historyBreakInfo hist num = breakInfo_number inf - case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of - Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num) + in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of + Just hmi -> modBreaks_locs (md_modBreaks (hm_details hmi)) ! num _ -> panic "getHistorySpan" +findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Name +findEnclosingDecl hsc_env mod span = + case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of + Nothing -> panic "findEnclosingDecl" + Just hmi -> let + globals = typeEnvIds (md_types (hm_details hmi)) + Just decl = find (\n -> nameSrcSpan n < span) + (reverse $ map idName globals) + -- ^^ assumes md_types is sorted + in decl + +-- | Find the Module corresponding to a FilePath +findModuleFromFile :: HscEnv -> FilePath -> Maybe Module +findModuleFromFile hsc_env fp = + listToMaybe $ [ms_mod ms | ms <- hsc_mod_graph hsc_env + , ml_hs_file(ms_location ms) == Just (read fp)] + + -- | Run a statement in the current interactive context. Statement -- may bind multple values. runStmt :: Session -> String -> SingleStep -> IO RunResult @@ -223,7 +255,7 @@ traceRunStatus expr ref bindings final_ids if b then handle_normally else do - let history' = consBL (History apStack info) history + let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. evaluate history' @@ -358,7 +390,7 @@ resume (Session ref) step when (isStep step) $ setStepFlag case r of Resume expr tid breakMVar statusMVar bindings - final_ids apStack info _ _ _ -> do + final_ids apStack info _ hist _ -> do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- withInterruptsSentTo @@ -366,14 +398,19 @@ resume (Session ref) step -- this awakens the stopped thread... return tid) (takeMVar statusMVar) - -- and wait for the result + -- and wait for the result + let hist' = + case info of + Nothing -> fromListBL 50 hist + Just i -> mkHistory hsc_env apStack i `consBL` + fromListBL 50 hist case step of RunAndLogSteps -> traceRunStatus expr ref bindings final_ids - breakMVar statusMVar status emptyHistory + breakMVar statusMVar status hist' _other -> handleRunStatus expr ref bindings final_ids - breakMVar statusMVar status emptyHistory + breakMVar statusMVar status hist' back :: Session -> IO ([Name], Int, SrcSpan) @@ -417,7 +454,7 @@ moveHist fn (Session ref) = do resumeBreakInfo = mb_info } -> update_ic apStack mb_info else case history !! (new_ix - 1) of - History apStack info -> + History apStack info _ -> update_ic apStack (Just info) -- ----------------------------------------------------------------------------- @@ -632,6 +669,8 @@ consBL a (BL len bound left right) toListBL (BL _ _ left right) = left ++ reverse right +fromListBL bound l = BL (length l) bound l [] + -- lenBL (BL len _ _ _) = len -- ----------------------------------------------------------------------------- @@ -711,8 +750,29 @@ moduleIsInterpreted s modl = withSession s $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) +-- Filter the instances by the ones whose tycons (or clases resp) +-- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! +-- The exact choice of which ones to show, and which to hide, is a judgement call. +-- (see Trac #1581) getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) -getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name +getInfo s name + = withSession s $ \hsc_env -> + do { mb_stuff <- tcRnGetInfo hsc_env name + ; case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, ispecs) -> do + { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } } + where + plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env + = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True -- The one we looked for in the first place! + | isBuiltInSyntax n = True + | isExternalName n = any ((== n) . gre_name) + (lookupGRE_Name rdr_env n) + | otherwise = True -- | Returns all names in scope in the current interactive context getNamesInScope :: Session -> IO [Name]