+
+-- -----------------------------------------------------------------------------
+-- commands for debugger
+
+sprintCmd = pprintCommand False False
+printCmd = pprintCommand True False
+forceCmd = pprintCommand False True
+
+pprintCommand bind force str = do
+ session <- getSession
+ io $ pprintClosureCommand session bind force str
+
+stepCmd :: String -> GHCi ()
+stepCmd [] = doContinue GHC.SingleStep
+stepCmd expression = do runStmt expression GHC.SingleStep; return ()
+
+traceCmd :: String -> GHCi ()
+traceCmd [] = doContinue GHC.RunAndLogSteps
+traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
+
+continueCmd :: String -> GHCi ()
+continueCmd = noArgs $ doContinue GHC.RunToCompletion
+
+doContinue :: SingleStep -> GHCi ()
+doContinue step = do
+ session <- getSession
+ runResult <- io $ GHC.resume session step
+ afterRunStmt runResult
+ return ()
+
+abandonCmd :: String -> GHCi ()
+abandonCmd = noArgs $ do
+ s <- getSession
+ b <- io $ GHC.abandon s -- 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
+ s <- getSession
+ resumes <- io $ GHC.getResumeContext s
+ case resumes of
+ [] -> io $ putStrLn "Not stopped at a breakpoint"
+ (r:rs) -> do
+ let hist = GHC.resumeHistory r
+ (took,rest) = splitAt num hist
+ spans <- mapM (io . GHC.getHistorySpan s) took
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
+ io $ putStrLn $ if null rest then "<end of history>" else "..."
+
+backCmd :: String -> GHCi ()
+backCmd = noArgs $ do
+ s <- getSession
+ (names, ix, span) <- io $ GHC.back s
+ printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
+ mapM_ (showTypeOfName s) names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
+forwardCmd :: String -> GHCi ()
+forwardCmd = noArgs $ do
+ s <- getSession
+ (names, ix, span) <- io $ GHC.forward s
+ printForUser $ (if (ix == 0)
+ then ptext SLIT("Stopped at")
+ else ptext SLIT("Logged breakpoint at")) <+> ppr span
+ mapM_ (showTypeOfName s) names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
+-- handle the "break" command
+breakCmd :: String -> GHCi ()
+breakCmd argLine = do
+ session <- getSession
+ breakSwitch session $ words argLine
+
+breakSwitch :: Session -> [String] -> GHCi ()
+breakSwitch _session [] = do
+ io $ putStrLn "The break command requires at least one argument."
+breakSwitch session args@(arg1:rest)
+ | looksLikeModuleName arg1 = do
+ mod <- wantInterpretedModule arg1
+ breakByModule session mod rest
+ | all isDigit arg1 = do
+ (toplevel, _) <- io $ GHC.getContext session
+ 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 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 :: Session -> Module -> [String] -> GHCi ()
+breakByModule session mod args@(arg1:rest)
+ | all isDigit arg1 = do -- looks like a line number
+ breakByModuleLine mod (read arg1) rest
+ | otherwise = io $ putStrLn "Invalid arguments to :break"
+
+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 = io $ putStrLn "Invalid arguments to :break"
+
+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
+ session <- getSession
+ 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 complete) `mplus`
+ listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
+ listToMaybe (sortBy rightmost ticks)
+ where
+ ticks = arr ! line
+
+ starts_here = [ tick | tick@(nm,span) <- ticks,
+ GHC.srcSpanStartLine span == line ]
+
+ (complete,incomplete) = partition ends_here starts_here
+ where ends_here (nm,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 contains)
+ where
+ ticks = arr ! line
+
+ -- the ticks that span this coordinate
+ contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
+ is_correct_file span ]
+
+ is_correct_file span
+ | Just f <- mb_file = GHC.srcSpanFile span == f
+ | otherwise = True
+
+
+leftmost_smallest (_,a) (_,b) = a `compare` b
+leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
+ `thenCmp`
+ (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
+rightmost (_,a) (_,b) = b `compare` a
+
+spans :: SrcSpan -> (Int,Int) -> Bool
+spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
+ where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
+
+start_bold = BS.pack "\ESC[1m"
+end_bold = BS.pack "\ESC[0m"
+
+listCmd :: String -> GHCi ()
+listCmd "" = do
+ mb_span <- getCurrentBreakSpan
+ case mb_span of
+ Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
+ Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
+ | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
+listCmd str = list2 (words str)
+
+list2 [arg] | all isDigit arg = do
+ session <- getSession
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ [] -> io $ putStrLn "No module to list"
+ (mod : _) -> listModuleLine mod (read arg)
+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
+ mod <- wantInterpretedModule arg1
+ listModuleLine mod (read arg2)
+list2 [arg] = do
+ wantNameFromInterpretedModule noCanDo arg $ \name -> do
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+ if GHC.isGoodSrcLoc loc
+ then do
+ tickArray <- getTickArray (GHC.nameModule name)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc, GHC.srcLocCol loc)
+ tickArray
+ case mb_span of
+ Nothing -> io $ listAround (GHC.srcLocSpan loc) False
+ Just (_,span) -> io $ listAround span False
+ else
+ noCanDo name $ text "can't find its location: " <>
+ ppr loc
+ where
+ noCanDo n why = printForUser $
+ text "cannot list source code for " <> ppr n <> text ": " <> why
+list2 _other =
+ io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
+
+listModuleLine :: Module -> Int -> GHCi ()
+listModuleLine modl line = do
+ session <- getSession
+ graph <- io (GHC.getModuleGraph session)
+ let this = filter ((== modl) . GHC.ms_mod) graph
+ case this of
+ [] -> panic "listModuleLine"
+ summ:_ -> do
+ let filename = fromJust (ml_hs_file (GHC.ms_location summ))
+ loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
+ io $ listAround (GHC.srcLocSpan loc) False
+
+-- | list a section of a source file around a particular SrcSpan.
+-- If the highlight flag is True, also highlight the span using
+-- start_bold/end_bold.
+listAround span do_highlight = do
+ contents <- BS.readFile (unpackFS file)
+ let
+ lines = BS.split '\n' contents
+ these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
+ drop (line1 - 1 - pad_before) $ lines
+ fst_line = max 1 (line1 - pad_before)
+ line_nos = [ fst_line .. ]
+
+ highlighted | do_highlight = zipWith highlight line_nos these_lines
+ | otherwise = these_lines
+
+ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
+ prefixed = zipWith BS.append bs_line_nos highlighted
+ --
+ BS.putStrLn (BS.join (BS.pack "\n") prefixed)
+ where
+ file = GHC.srcSpanFile span
+ line1 = GHC.srcSpanStartLine span
+ col1 = GHC.srcSpanStartCol span
+ line2 = GHC.srcSpanEndLine span
+ col2 = GHC.srcSpanEndCol span
+
+ pad_before | line1 == 1 = 0
+ | otherwise = 1
+ pad_after = 1
+
+ highlight no line
+ | no == line1 && no == line2
+ = let (a,r) = BS.splitAt col1 line
+ (b,c) = BS.splitAt (col2-col1) r
+ in
+ BS.concat [a,start_bold,b,end_bold,c]
+ | no == line1
+ = let (a,b) = BS.splitAt col1 line in
+ BS.concat [a, start_bold, b]
+ | no == line2
+ = let (a,b) = BS.splitAt col2 line in
+ BS.concat [a, end_bold, b]
+ | otherwise = line
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: Module -> GHCi TickArray
+getTickArray modl = do
+ st <- getGHCiState
+ let arrmap = tickarrays st
+ case lookupModuleEnv arrmap modl of
+ Just arr -> return arr
+ Nothing -> do
+ (breakArray, ticks) <- getModBreak modl
+ let arr = mkTickArray (assocs ticks)
+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+ return arr
+
+discardTickArrays :: GHCi ()
+discardTickArrays = do
+ st <- getGHCiState
+ setGHCiState st{tickarrays = emptyModuleEnv}
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+ = accumArray (flip (:)) [] (1, max_line)
+ [ (line, (nm,span)) | (nm,span) <- ticks,
+ line <- srcSpanLines span ]
+ where
+ max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
+ srcSpanLines span = [ GHC.srcSpanStartLine span ..
+ GHC.srcSpanEndLine span ]
+
+lookupModule :: String -> GHCi Module
+lookupModule modName
+ = do session <- getSession
+ io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do
+ st <- getGHCiState
+ mapM (turnOffBreak.snd) (breaks st)
+ setGHCiState $ st { breaks = [] }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+ st <- getGHCiState
+ let oldLocations = breaks st
+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations
+ if null this
+ then printForUser (text "Breakpoint" <+> ppr identity <+>
+ text "does not exist")
+ else do
+ mapM (turnOffBreak.snd) this
+ setGHCiState $ st { breaks = rest }
+
+turnOffBreak loc = do
+ (arr, _) <- getModBreak (breakModule loc)
+ io $ setBreakFlag False arr (breakTick loc)
+
+getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
+getModBreak mod = do
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session mod
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let array = GHC.modBreaks_flags modBreaks
+ let ticks = GHC.modBreaks_locs modBreaks
+ return (array, ticks)
+
+setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
+setBreakFlag toggle array index
+ | toggle = GHC.setBreakOn array index
+ | otherwise = GHC.setBreakOff array index
+