-setUpConsole :: IO ()
-setUpConsole = do
-#ifdef mingw32_HOST_OS
- -- On Windows we need to set a known code page, otherwise the characters
- -- we read from the console will be be in some strange encoding, and
- -- similarly for characters we write to the console.
- --
- -- At the moment, GHCi pretends all input is Latin-1. In the
- -- future we should support UTF-8, but for now we set the code pages
- -- to Latin-1.
- --
- -- It seems you have to set the font in the console window to
- -- a Unicode font in order for output to work properly,
- -- otherwise non-ASCII characters are mapped wrongly. sigh.
- -- (see MSDN for SetConsoleOutputCP()).
- --
- setConsoleCP 28591 -- ISO Latin-1
- setConsoleOutputCP 28591 -- ISO Latin-1
-#endif
- return ()
-
-
-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` (\e -> case e of
- StopChildSession -> evaluate$
- throwDyn (ChildSessionStopped "")
- StopParentSession -> throwDyn StopParentSession
- ) `finally` do
- writeIORef ref hsc_env
- putStrLn $ "Returning to normal execution..."
- return b
+-- -----------------------------------------------------------------------------
+-- commands for debugger
+
+sprintCmd, printCmd, forceCmd :: String -> GHCi ()
+sprintCmd = pprintCommand False False
+printCmd = pprintCommand True False
+forceCmd = pprintCommand False True
+
+pprintCommand :: Bool -> Bool -> String -> GHCi ()
+pprintCommand bind force str = do
+ pprintClosureCommand bind force str
+
+stepCmd :: String -> GHCi ()
+stepCmd [] = doContinue (const True) GHC.SingleStep
+stepCmd expression = do runStmt expression GHC.SingleStep; return ()
+
+stepLocalCmd :: String -> GHCi ()
+stepLocalCmd [] = do
+ mb_span <- getCurrentBreakSpan
+ case mb_span of
+ Nothing -> stepCmd []
+ Just loc -> do
+ Just mod <- getCurrentBreakModule
+ current_toplevel_decl <- enclosingTickSpan mod loc
+ doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
+
+stepLocalCmd expression = stepCmd expression
+
+stepModuleCmd :: String -> GHCi ()
+stepModuleCmd [] = do
+ mb_span <- getCurrentBreakSpan
+ case mb_span of
+ Nothing -> stepCmd []
+ Just _ -> do
+ Just span <- getCurrentBreakSpan
+ let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
+ doContinue f GHC.SingleStep
+
+stepModuleCmd expression = stepCmd expression
+
+-- | Returns the span of the largest tick containing the srcspan given
+enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
+enclosingTickSpan mod src = do
+ ticks <- getTickArray mod
+ let line = srcSpanStartLine src
+ ASSERT (inRange (bounds ticks) line) do
+ let enclosing_spans = [ span | (_,span) <- ticks ! line
+ , srcSpanEnd span >= srcSpanEnd src]
+ return . head . sortBy leftmost_largest $ enclosing_spans
+
+traceCmd :: String -> GHCi ()
+traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
+traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
+
+continueCmd :: String -> GHCi ()
+continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
+
+-- doContinue :: SingleStep -> GHCi ()
+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
+doContinue pred step = do
+ runResult <- resume pred step
+ afterRunStmt pred runResult
+ return ()
+
+abandonCmd :: String -> GHCi ()
+abandonCmd = noArgs $ do
+ b <- GHC.abandon -- the prompt will change to indicate the new context
+ when (not b) $ io $ putStrLn "There is no computation running."
+ return ()
+
+deleteCmd :: String -> GHCi ()
+deleteCmd argLine = do
+ deleteSwitch $ words argLine
+ where
+ deleteSwitch :: [String] -> GHCi ()
+ deleteSwitch [] =
+ io $ putStrLn "The delete command requires at least one argument."
+ -- delete all break points
+ deleteSwitch ("*":_rest) = discardActiveBreakPoints
+ deleteSwitch idents = do
+ mapM_ deleteOneBreak idents
+ where
+ deleteOneBreak :: String -> GHCi ()
+ deleteOneBreak str
+ | all isDigit str = deleteBreak (read str)
+ | otherwise = return ()
+
+historyCmd :: String -> GHCi ()
+historyCmd arg
+ | null arg = history 20
+ | all isDigit arg = history (read arg)
+ | otherwise = io $ putStrLn "Syntax: :history [num]"
+ where
+ history num = do
+ resumes <- GHC.getResumeContext
+ case resumes of
+ [] -> io $ putStrLn "Not stopped at a breakpoint"
+ (r:_) -> do
+ let hist = GHC.resumeHistory r
+ (took,rest) = splitAt num hist
+ case hist of
+ [] -> io $ putStrLn $
+ "Empty history. Perhaps you forgot to use :trace?"
+ _ -> do
+ spans <- mapM GHC.getHistorySpan took
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ names = map GHC.historyEnclosingDecl took
+ printForUser (vcat(zipWith3
+ (\x y z -> x <+> y <+> z)
+ (map text nums)
+ (map (bold . ppr) names)
+ (map (parens . ppr) spans)))
+ io $ putStrLn $ if null rest then "<end of history>" else "..."
+
+bold :: SDoc -> SDoc
+bold c | do_bold = text start_bold <> c <> text end_bold
+ | otherwise = c
+
+backCmd :: String -> GHCi ()
+backCmd = noArgs $ do
+ (names, _, span) <- GHC.back
+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
+ printTypeOfNames names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
+forwardCmd :: String -> GHCi ()
+forwardCmd = noArgs $ do
+ (names, ix, span) <- GHC.forward
+ printForUser $ (if (ix == 0)
+ then ptext (sLit "Stopped at")
+ else ptext (sLit "Logged breakpoint at")) <+> ppr span
+ printTypeOfNames names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
+-- handle the "break" command
+breakCmd :: String -> GHCi ()
+breakCmd argLine = do
+ breakSwitch $ words argLine
+
+breakSwitch :: [String] -> GHCi ()
+breakSwitch [] = do
+ io $ putStrLn "The break command requires at least one argument."
+breakSwitch (arg1:rest)
+ | looksLikeModuleName arg1 && not (null rest) = do
+ mod <- wantInterpretedModule arg1
+ breakByModule mod rest
+ | all isDigit arg1 = do
+ (toplevel, _) <- GHC.getContext
+ case toplevel of
+ (mod : _) -> breakByModuleLine mod (read arg1) rest
+ [] -> do
+ io $ putStrLn "Cannot find default module for breakpoint."
+ io $ putStrLn "Perhaps no modules are loaded for debugging?"
+ | otherwise = do -- try parsing it as an identifier
+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+ if GHC.isGoodSrcLoc loc
+ then ASSERT( isExternalName name )
+ findBreakAndSet (GHC.nameModule name) $
+ findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc,
+ GHC.srcLocCol loc)
+ else noCanDo name $ text "can't find its location: " <> ppr loc
+ where
+ noCanDo n why = printForUser $
+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why
+
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule mod (arg1:rest)
+ | all isDigit arg1 = do -- looks like a line number
+ breakByModuleLine mod (read arg1) rest
+breakByModule _ _
+ = breakSyntax
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine mod line args
+ | [] <- args = findBreakAndSet mod $ findBreakByLine line
+ | [col] <- args, all isDigit col =
+ findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
+ | otherwise = breakSyntax
+
+breakSyntax :: a
+breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
+
+findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet mod lookupTickTree = do
+ tickArray <- getTickArray mod
+ (breakArray, _) <- getModBreak mod
+ case lookupTickTree tickArray of
+ Nothing -> io $ putStrLn $ "No breakpoints found at that location."
+ Just (tick, span) -> do
+ success <- io $ setBreakFlag True breakArray tick
+ if success
+ then do
+ (alreadySet, nm) <-
+ recordBreak $ BreakLocation
+ { breakModule = mod
+ , breakLoc = span
+ , breakTick = tick
+ , onBreakCmd = ""
+ }
+ printForUser $
+ text "Breakpoint " <> ppr nm <>
+ if alreadySet
+ then text " was already set at " <> ppr span
+ else text " activated at " <> ppr span
+ else do
+ printForUser $ text "Breakpoint could not be activated at"
+ <+> ppr span
+
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+-- - the leftmost complete subexpression on the specified line, or
+-- - the leftmost subexpression starting on the specified line, or
+-- - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByLine line arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
+ listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
+ listToMaybe (sortBy (rightmost `on` snd) ticks)
+ where
+ ticks = arr ! line
+
+ starts_here = [ tick | tick@(_,span) <- ticks,
+ GHC.srcSpanStartLine span == line ]
+
+ (complete,incomplete) = partition ends_here starts_here
+ where ends_here (_,span) = GHC.srcSpanEndLine span == line
+
+findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
+ -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord mb_file (line, col) arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy (rightmost `on` snd) contains ++
+ sortBy (leftmost_smallest `on` snd) after_here)