+
+-- -----------------------------------------------------------------------------
+-- 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
+
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
+
+stepCmd :: String -> GHCi Bool
+stepCmd [] = doContinue setStepFlag
+stepCmd expression = do
+ io $ setStepFlag
+ runCommand expression
+
+continueCmd :: String -> GHCi Bool
+continueCmd [] = doContinue $ return ()
+continueCmd other = do
+ io $ putStrLn "The continue command accepts no arguments."
+ return False
+
+doContinue :: IO () -> GHCi Bool
+doContinue actionBeforeCont = do
+ resumeAction <- popResume
+ case resumeAction of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ return False
+ Just eval -> do
+ io $ actionBeforeCont
+ session <- getSession
+ runResult <- io $ GHC.resume session (evalResumeHandle eval)
+ names <- switchOnRunResult (evalStmt eval) runResult
+ finishEvalExpr names
+ return False
+
+abandonCmd :: String -> GHCi ()
+abandonCmd "" = do
+ mb_res <- popResume
+ case mb_res of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ Just eval ->
+ return ()
+ -- the prompt will change to indicate the new context
+
+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 ()
+
+-- 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 session 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 -- assume it's a name
+ names <- io $ GHC.parseName session arg1
+ case names of
+ [] -> return ()
+ (n:_) -> do
+ let loc = GHC.nameSrcLoc n
+ modl = GHC.nameModule n
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ if not is_interpreted
+ then noCanDo $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else do
+ if GHC.isGoodSrcLoc loc
+ then findBreakAndSet (GHC.nameModule n) $
+ findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc,
+ GHC.srcLocCol loc)
+ else noCanDo $ text "can't find its location: " <>
+ ppr loc
+ where
+ noCanDo why = printForUser $
+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why
+
+
+wantInterpretedModule :: Session -> String -> GHCi Module
+wantInterpretedModule session str = do
+ modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+ return modl
+
+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
+ }
+ 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 str = do
+ st <- getGHCiState
+ case resume st of
+ [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
+ eval:_ -> io $ listAround (evalSpan eval) True
+
+-- | 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 = maximum (map GHC.srcSpanEndLine (map snd ticks))
+ srcSpanLines span = [ GHC.srcSpanStartLine span ..
+ GHC.srcSpanEndLine span ]
+
+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)
+
+lookupModule :: Session -> String -> GHCi Module
+lookupModule session modName
+ = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
+setBreakFlag toggle array index
+ | toggle = GHC.setBreakOn array index
+ | otherwise = GHC.setBreakOff array index
+
+
+{- these should probably go to the GHC API at some point -}
+enableBreakPoint :: Session -> Module -> Int -> IO ()
+enableBreakPoint session mod index = return ()
+
+disableBreakPoint :: Session -> Module -> Int -> IO ()
+disableBreakPoint session mod index = return ()
+
+activeBreakPoints :: Session -> IO [(Module,Int)]
+activeBreakPoints session = return []
+
+enableSingleStep :: Session -> IO ()
+enableSingleStep session = return ()
+
+disableSingleStep :: Session -> IO ()
+disableSingleStep session = return ()