+
+
+instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
+instrumentationBkptHandler ref_bkptTable = BkptHandler {
+ isAutoBkptEnabled = \sess bkptLoc -> do
+ bktpTable <- readIORef ref_bkptTable
+ return$ isBkptEnabled bktpTable bkptLoc
+
+ , handleBreakpoint = doBreakpoint ref_bkptTable
+ }
+
+doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
+doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
+ let (ids, hValues) = unzip values
+ names = map idName ids
+ ASSERT (length names == length hValues) return ()
+ let global_ids = map globaliseAndTidy ids
+ printScopeMsg locMsg global_ids
+ typed_ids <- mapM instantiateIdType global_ids
+ hsc_env <- readIORef ref
+ let ictxt = hsc_IC hsc_env
+ rn_env = ic_rn_local_env ictxt
+ type_env = ic_type_env ictxt
+ bound_names = map idName typed_ids
+ new_rn_env = extendLocalRdrEnv rn_env bound_names
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+ filtered_type_env = delListFromNameEnv type_env shadowed
+ new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ writeIORef ref (hsc_env { hsc_IC = new_ic })
+ is_tty <- hIsTerminalDevice stdin
+ prel_mod <- GHC.findModule s prel_name Nothing
+ withExtendedLinkEnv (zip names hValues) $
+ startGHCi (interactiveLoop is_tty True) GHCiState{
+ progname = "<interactive>",
+ args = [],
+ prompt = locMsg ++ "> ",
+ session = s,
+ options = [],
+ bkptTable= ref_bkptTable,
+ prelude = prel_mod,
+ topLevel = False }
+ `catchDyn` (
+ \StopChildSession -> evaluate$
+ throwDyn (ChildSessionStopped "")
+ ) `finally` do
+ writeIORef ref hsc_env
+ putStrLn $ "Returning to normal execution..."
+ return b
+ where
+ printScopeMsg :: String -> [Id] -> IO ()
+ printScopeMsg location ids = do
+ unqual <- GHC.getPrintUnqual s
+ printForUser stdout unqual $
+ text "Stopped at a breakpoint in " <> text (stripColumn location) <>
+ char '.' <+> text "Local bindings in scope:" $$
+ nest 2 (pprWithCommas showId ids)
+ where
+ showId id =
+ ppr (idName id) <+> dcolon <+> ppr (idType id)
+ stripColumn = reverse . tail . dropWhile (/= ':') . reverse
+
+-- | Give the Id a Global Name, and tidy its type
+ globaliseAndTidy :: Id -> Id
+ globaliseAndTidy id
+ = let tidied_type = tidyTopType$ idType id
+ in setIdType (globaliseId VanillaGlobal id) tidied_type
+
+-- | Instantiate the tyVars with GHC.Base.Unknown
+ instantiateIdType :: Id -> IO Id
+ instantiateIdType id = do
+ instantiatedType <- instantiateTyVarsToUnknown s (idType id)
+ return$ setIdType id instantiatedType
+
+