Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

pure tests pass

  • Loading branch information...
commit bd4a62f3f97f9d528f7983a5f69415898cc662e2 1 parent 3c1806a
Alexander Bernauer authored
View
198 GDBMI.hs
@@ -1,198 +0,0 @@
--- hgdbmi: a Haskell interface to GDB/MI.
--- Copyright (C) 2008 Evan Martin <martine@danga.com>
-
--- |GDB\/MI lets programs drive GDB. It can be used, for example, by GDB
--- frontends. This module wraps attaching GDB to a process and parsing the
--- (surprisingly complicated) GDB\/MI output.
-
-module GDBMI (
- GDB,
- attach,
- detach,
-
- runCommand,
- GDBCommand(..),
- MIOutput(..),
- MIOOB(..),
- MIResult(..),
- MIKeyVal,
- MIValue(..),
-
- parse
-) where
-
-import System.IO
-import System.Posix.IO (createPipe, fdToHandle)
-import System.Posix.Types (ProcessID)
-import System.Process (runProcess, ProcessHandle)
-import Text.ParserCombinators.Parsec hiding (parse)
-import qualified Text.ParserCombinators.Parsec as Parsec (parse)
-
--- |A connection to a GDB process.
-data GDB = GDB {
- gdbPid :: ProcessHandle,
- gdbCommand :: Handle,
- gdbResponse :: Handle
-}
-
--- |A GDB command. CLICommand is any command you'd normally type at the GDB
--- prompt. MICommand are more machine-parsing friendly commands; see the
--- GDB\/MI docs for details.
-data GDBCommand = CLICommand String
- | MICommand String -- ^TODO: expand this to support arguments.
-
--- |The output of running a GDB command. Output is a collection of Out-Of-Band
--- messages (such as logging information) and an optional final result.
-data MIOutput = MIOutput [MIOOB] (Maybe MIResult) deriving Show
-
--- |The type of OOB mesages. (TODO: many of these aren't properly parsed yet.)
-data MIOOB =
- MIStatus String -- ^Contains on-going status information about the progress
- -- of a slow operation.
- | MIExec String -- ^Contains asynchronous state change on the target
- -- (stopped, started, disappeared).
- | MINotify String -- ^Contains supplementary information that the client
- -- should handle (e.g., a new breakpoint information).
- | MIConsole String -- ^Output that should be displayed as is in the console.
- -- It is the textual response to a CLI command.
- | MITarget String -- ^The output produced by the target program.
- | MILog String -- ^Output text coming from GDB's internals, for instance
- -- messages that should be displayed as part of an error
- -- log.
- deriving (Eq, Show)
-
--- |The type of the GDB result. (TODO: many result types aren't implemented
--- yet.)
-data MIResult =
- MIDone [MIKeyVal] -- ^The synchronous operation was successful,
- -- along with potential key-value return data.
- | MIError String -- ^The operation failed. The string contains the
- -- corresponding error message.
- deriving (Eq, Show)
-
--- |A key-value pair output from GDB.
-type MIKeyVal = (String, MIValue)
-
--- |The type of a GDB "value", used in the output of structured data.
-data MIValue =
- MIString String
- | MITuple [MIKeyVal]
- deriving (Eq, Show)
-
--- |Attach to a process, returning an error or the 'GDB' connection and its
--- initial output.
-attach :: Maybe FilePath -- ^Working directory for GDB. (Important if the
- -- process has loaded libraries from relative paths.)
- -> ProcessID
- -> IO (Either String (GDB, MIOutput))
-attach workdir pid = do
- (commandR, commandW) <- createPipe >>= asHandles
- (responseR, responseW) <- createPipe >>= asHandles
- phandle <- runProcess "gdb" ["--interpreter", "mi", "-p", show pid]
- workdir Nothing{-env-}
- (Just commandR) -- stdin
- (Just responseW) -- stdout
- Nothing -- stderr
- mapM_ (`hSetBuffering` LineBuffering) [commandW, responseR]
- let gdb = GDB phandle commandW responseR
- resp <- readResponse gdb
- case resp of
- Left err -> return $ Left err
- Right ok -> return $ Right (gdb, ok)
- where
- asHandles (f1, f2) = do
- h1 <- fdToHandle f1; h2 <- fdToHandle f2; return (h1, h2)
-
--- |Close a 'GDB' connection.
-detach :: GDB -> IO ()
--- TODO: we don't examine the result code, because our parser wants each
--- response to be terminated by the "(gdb) " prompt, which this lacks.
-detach gdb = hPutStrLn (gdbCommand gdb) "-gdb-exit"
-
--- |Run a GDB command.
-runCommand :: GDBCommand -> GDB -> IO (Either String MIOutput)
-runCommand cmd gdb = do
- hPutStrLn (gdbCommand gdb) (cmdStr cmd)
- readResponse gdb
- where
- cmdStr (CLICommand str) = str
- cmdStr (MICommand str) = '-' : str
-
-readResponse :: GDB -> IO (Either String MIOutput)
-readResponse gdb = do
- resp <- readResponseLines
- case parse "output" (unlines resp) of
- Left err -> return $ Left (show err)
- Right out -> return $ Right out
- where
- readResponseLines :: IO [String]
- readResponseLines = do
- line <- hGetLine (gdbResponse gdb)
- if line == "(gdb) "
- then return []
- else do rest <- readResponseLines
- return (line:rest)
-
--- Our Parsec parsers all start with p_.
-
--- Parse the main ouptut from GDB.
-p_output = do
- oob <- p_oob `sepEndBy` newline
- res <- optionMaybe p_result
- eof
- return $ MIOutput oob res
--- Parse an "OOB" message from GDB.
-p_oob = p_console <|> p_log
--- Parse a console OOB message from GDB.
-p_console = do char '~'; str <- p_cstring; return $ MIConsole str
--- Parse a log OOB message from GDB.
-p_log = do char '&'; str <- p_cstring; return $ MILog str
-
--- Parse a result message from GDB.
-p_result = do
- char '^'
- res <- p_done <|> p_error
- newline; return res
- where
- -- Parse a done result message from GDB.
- p_done = do
- string "done"
- res <- (do char ','; p_keyval `sepBy` char ',') <|> return []
- return $ MIDone res
- -- Parse a error result message from GDB.
- p_error = do
- string "error"
- char ','
- -- XXX: The GDB/MI docs say this should be just a cstring, but my GDB
- -- doesn't agree.
- string "msg=" -- Hack here; perhaps it's really like the "done" output?
- err <- p_cstring
- return $ MIError err
-
--- Parse a key=val output ("result") from GDB.
-p_keyval = do var <- p_var; char '='; val <- p_val; return $ (var, val) where
- p_var = many1 (letter <|> char '-') -- XXX: this is underspecified.
- p_val = p_const <|> p_tuple
- p_const = do str <- p_cstring; return $ MIString str
- p_tuple = do
- vals <- tuplewrap $ p_keyval `sepBy` char ','
- return $ MITuple vals
- -- It's unclear why they have []-style tuples and {}-style tuples...
- tuplewrap p = between (char '{') (char '}') p
- <|> between (char '[') (char ']') p
-
--- Parse a C-style string (underspecified by the GDB manual).
-p_cstring = between (char '"') (char '"') (many p_cchar) where
- p_cchar = p_cbackslash
- <|> noneOf "\""
- p_cbackslash = do
- char '\\'
- c <- anyChar
- case c of
- '\\' -> return '\\'
- 'n' -> return '\n'
- '"' -> return '"'
- _ -> fail $ "unknown backslash escape: " ++ show c
-
--- |An interface to the output parser. Just used for testing.
-parse = Parsec.parse p_output
View
25 hgdbmi.cabal
@@ -2,25 +2,27 @@ name: hgdbmi
category: Development
version: 0.2
license: BSD3
-cabal-version: >= 1.14
+cabal-version: >= 1.14
license-file: LICENSE
author: Alexander Bernauer, Evan Martin
maintainer: Alexander Bernauer <acopton@gmail.com>
stability: provisional
homepage: https://github.com/copton/hgdbmi
bug-reports: https://github.com/copton/hgdbmi/issues
-copyright: (c) 2012 Alexander Bernauer <acopton@gmail.com>, (c) 2008 Evan Martin <martine@danga.com>
+copyright: (c) 2012 Alexander Bernauer <acopton@gmail.com>, 2008 Evan Martin <martine@danga.com>
Synopsis: GDB Machine Interface: program-driven control of GDB
Description:
GDB\/MI lets programs drive GDB. It can be used, for example, by GDB
- frontends. This module encapsualtes a GDB subprocess and provides an
- API to send commands as well as receive both responses and notifications.
+ frontends. See section 27 of the GDB manual
+ .
+ This module encapsualtes a GDB subprocess and provides an API to send
+ commands as well as receive both responses and notifications.
.
The actual GDB behavior diverges from the GDB manual in many points, so the
implementation of the Machine Interface highly depends on the GDB version.
- This module supports GDB version 7.4.
+ This module is tested with GDB version 7.4.
-build-type: custom
+build-type: Simple
tested-with: GHC == 7.4.2
extra-source-files:
gdb-manual.pdf
@@ -39,7 +41,8 @@ library
base >= 4 && < 5,
parsec == 3.1.*,
process == 1.1.*,
- unix == 2.6.*
+ unix == 2.6.*,
+ stm == 2.3.*
exposed-modules:
Gdbmi.IO
@@ -49,17 +52,19 @@ library
ghc-options: -Wall
hs-source-dirs: src
+ default-language: Haskell2010
test-suite pure
type: exitcode-stdio-1.0
main-is: pure.hs
- other-modules: Lib.hs
build-depends:
+ hgdbmi,
base >= 4 && < 5,
HUnit == 1.2.*,
test-framework == 0.6.*,
test-framework-hunit == 0.2.*,
template-haskell
- ghc-options: -Wall
- hs-source-dirs: tests
+ ghc-options: -Wall
+ hs-source-dirs: tests
+ default-language: Haskell2010
View
6 src/Gdbmi.hs
@@ -0,0 +1,6 @@
+module Gdbmi
+
+import Gdbmi.IO
+import Gdbmi.Representation
+import Gdbmi.Commands
+import Gdbmi.Responses
View
630 src/Gdbmi/Commands.hs
@@ -0,0 +1,630 @@
+module Gdbmi.Commands where
+
+-- imports {{{1
+import Data.List (intersperse)
+import Data.Maybe (fromMaybe)
+import Gdbmi.Representation hiding (Exec, Console)
+import Prelude hiding (reverse, all, lines)
+
+-- types {{{1
+class GdbShow a where -- {{{2
+ gdbShow :: a -> String
+
+instance GdbShow Char where
+ gdbShow = (:[])
+
+instance GdbShow a => GdbShow [a] where
+ gdbShow = concatMap gdbShow
+
+instance GdbShow Int where
+ gdbShow = show
+
+type Location = String -- {{{2
+
+positive_offset_location :: Int -> Location -- {{{3
+positive_offset_location offset = "+" ++ gdbShow offset
+
+negative_offset_location :: Int -> Location -- {{{3
+negative_offset_location offset = "-" ++ gdbShow offset
+
+file_line_location :: String -> Int -> Location -- {{{3
+file_line_location filename linenum = filename ++ ":" ++ gdbShow linenum
+
+function_location :: String -> Location -- {{{3
+function_location = id
+
+function_label_location :: String -> String -> Location -- {{{3
+function_label_location function label = function ++ ":" ++ label
+
+file_function_location :: String -> String -> Location -- {{{3
+file_function_location filename function = filename ++ ":" ++ function
+
+label_location :: String -> Location -- {{{3
+label_location = id
+
+plain_address_location :: String -> Location -- {{{3
+plain_address_location = ("*"++)
+
+expr_address_location :: String -> Location -- {{{3
+expr_address_location = plain_address_location
+
+func_address_location :: String -> Location -- {{{3
+func_address_location = plain_address_location
+
+file_func_address_location :: String -> String -> Location -- {{{3
+file_func_address_location filename funcaddr = "'" ++ filename ++ "'::" ++ funcaddr
+
+data PrintValues -- {{{2
+ = NoValues
+ | AllValues
+ | SimpleValues
+
+instance GdbShow PrintValues where
+ gdbShow NoValues = "--no-values"
+ gdbShow AllValues = "--all-values"
+ gdbShow SimpleValues = "--simple-values"
+
+mapPrintValues :: (PrintValues -> a) -> Int -> a
+mapPrintValues f 0 = f NoValues
+mapPrintValues f 1 = f AllValues
+mapPrintValues f 2 = f SimpleValues
+mapPrintValues _ _ = error "valid integers for the print-value parameter range from 0 to 2 only"
+
+data FrameSelect -- {{{2
+ = FrameAddr String
+ | CurrentFrame
+ | Floating
+
+instance GdbShow FrameSelect where
+ gdbShow (FrameAddr addr) = addr
+ gdbShow CurrentFrame = "*"
+ gdbShow Floating = "@"
+
+data FormatSpec -- {{{2
+ = Binary
+ | Decimal
+ | Hexadecimal
+ | Octal
+ | Natural
+
+instance GdbShow FormatSpec where
+ gdbShow Binary = "binary"
+ gdbShow Decimal = "decimal"
+ gdbShow Hexadecimal = "hexadecimal"
+ gdbShow Octal = "octal"
+ gdbShow Natural = "natural"
+
+data FrozenFlag -- {{{2
+ = Frozen
+ | Unfrozen
+
+instance GdbShow FrozenFlag where
+ gdbShow Frozen = "1"
+ gdbShow Unfrozen = "0"
+
+data DisassemblyMode -- {{{2
+ = DisassemblyMode Bool Bool -- mixed source and disassembly, raw opcodes
+
+instance GdbShow DisassemblyMode where
+ gdbShow (DisassemblyMode False False) = "0"
+ gdbShow (DisassemblyMode True False) = "1"
+ gdbShow (DisassemblyMode False True) = "2"
+ gdbShow (DisassemblyMode True True) = "3"
+
+data DataFormat -- {{{2
+ = DHexadecimal
+ | DOctal
+ | DBinary
+ | DDecimal
+ | DRaw
+ | DNatural
+
+instance GdbShow DataFormat where
+ gdbShow DHexadecimal = "x"
+ gdbShow DOctal = "o"
+ gdbShow DBinary = "t"
+ gdbShow DDecimal = "d"
+ gdbShow DRaw = "r"
+ gdbShow DNatural = "N"
+
+data OutputFormat -- {{{2
+ = HexadecimalInteger
+ | SignedDecimalInteger
+ | UnsignedDecimalInteger
+ | OctalInteger
+ | BinaryInteger
+ | Address
+ | CharacterConstantInteger
+ | FloatingPointNumber
+ | OString
+ | Raw
+
+instance GdbShow OutputFormat where
+ gdbShow HexadecimalInteger = "x"
+ gdbShow SignedDecimalInteger = "d"
+ gdbShow UnsignedDecimalInteger = "u"
+ gdbShow OctalInteger = "o"
+ gdbShow BinaryInteger = "t"
+ gdbShow Address = "a"
+ gdbShow CharacterConstantInteger = "c"
+ gdbShow FloatingPointNumber = "f"
+ gdbShow OString = "s"
+ gdbShow Raw = "r"
+
+data TraceMode -- {{{2
+ = None
+ | FrameNumber Int
+ | TracepointNumber Int
+ | PC String
+ | PCInsideRange String String
+ | PCOutsideRange String String
+ | Line Location
+
+instance GdbShow TraceMode where
+ gdbShow None = "none"
+ gdbShow (FrameNumber _) = "frame-number"
+ gdbShow (TracepointNumber _) = "tracepoint-number"
+ gdbShow (PC _) = "pc"
+ gdbShow (PCInsideRange _ _) = "pc-inside-range"
+ gdbShow (PCOutsideRange _ _) = "pc-outside-range"
+ gdbShow (Line _) = "line"
+
+traceModeOptions :: TraceMode -> [Option]
+traceModeOptions None = []
+traceModeOptions (FrameNumber x) = [opt x]
+traceModeOptions (TracepointNumber x) = [opt x]
+traceModeOptions (PC x) = [opt x]
+traceModeOptions (PCInsideRange x y) = [opt x, opt y]
+traceModeOptions (PCOutsideRange x y) = [opt x, opt y]
+traceModeOptions (Line x) = [opt x]
+
+data Target -- {{{2
+ = Exec FilePath
+ | Core FilePath
+ | Remote Medium
+ | Sim [String]
+ | Nrom
+
+instance GdbShow Target where
+ gdbShow (Exec _) = "exec"
+ gdbShow (Core _) = "core"
+ gdbShow (Remote _) = "remote"
+ gdbShow (Sim _) = "sim"
+ gdbShow Nrom = "nrom"
+
+targetOptions :: Target -> [Option]
+targetOptions (Exec x) = [opt x]
+targetOptions (Core x) = [opt x]
+targetOptions (Remote x) = [opt x]
+targetOptions (Sim xs) = map opt xs
+targetOptions Nrom = []
+
+data Medium -- {{{2
+ = SerialDevice String
+ | TcpHost String Int
+ | UdpHost String Int
+ | Pipe String
+
+instance GdbShow Medium where
+ gdbShow (SerialDevice device) = device
+ gdbShow (TcpHost host port) = "tcp:" ++ host ++ ":" ++ gdbShow port
+ gdbShow (UdpHost host port) = "udp:" ++ host ++ ":" ++ gdbShow port
+ gdbShow (Pipe command) = "| " ++ command
+
+data Interpreter -- {{{2
+ = Console
+ | MI
+ | MI2
+ | MI1
+
+instance GdbShow Interpreter where
+ gdbShow Console = "console"
+ gdbShow MI = "mi"
+ gdbShow MI2 = "mi2"
+ gdbShow MI1 = "mi1"
+
+-- helper {{{1
+add_token :: Token -> Command -> Command -- {{{2
+add_token token (MICommand _ x y z) = MICommand (Just token) x y z
+add_token token (CLICommand _ x) = CLICommand (Just token) x
+
+-- add_parameters :: [Parameter] -> Command -> Command -- {{{2
+-- add_parameters ps (MICommand x y z ps') = MICommand x y z (ps'++ps)
+-- add_parameters ps (CLICommand t s) = CLICommand t (s ++ intercalate " " ps)
+
+-- commands {{{1
+-- breakpoint commands {{{2
+break_after :: Int -> Int -> Command -- {{{3
+break_after number count = cmd "break-after" $ map opt [number, count]
+
+break_commands :: Int -> [String] -> Command -- {{{3
+break_commands number commands = cmd "break-commands" $ opt number : map opt commands
+
+break_condition :: Int -> String -> Command -- {{{3
+break_condition number expr = cmd "break-condition" $ opt number : opt expr : []
+
+break_delete :: [Int] -> Command -- {{{3
+break_delete numbers = cmd "break-delete" $ map optr numbers
+
+break_disable :: [Int] -> Command -- {{{3
+break_disable numbers = cmd "break-disable" $ map opt numbers
+
+break_enable :: [Int] -> Command -- {{{3
+break_enable numbers = cmd "break-enable" $ map opt numbers
+
+break_info :: Int -> Command -- {{{3
+break_info number = cmd "break-info" [opt number]
+
+break_insert :: Bool -> Bool -> Bool -> Bool -> Bool -> Maybe String -> Maybe Int -> Maybe Int -> Location -> Command -- {{{3
+break_insert temporary hardware pending disabled tracepoint condition ignoreCount threadId location =
+ cmd "break-insert" $ temporary' ?: hardware' ?: pending' ?: disabled' ?: tracepoint' ?: condition' ?: ignoreCount' ?: threadId' ?: opt location : []
+ where
+ temporary' = flagOpt "-t" temporary
+ hardware' = flagOpt "-h" hardware
+ pending' = flagOpt "-p" pending
+ disabled' = flagOpt "-d" disabled
+ tracepoint' = flagOpt "-a" tracepoint
+ condition' = valueOpt "-c" condition
+ ignoreCount' = valueOpt "-i" ignoreCount
+ threadId' = valueOpt "-p" threadId
+
+break_list :: Command -- {{{3
+break_list = cmd "break-list" []
+
+break_passcount :: Int -> Int -> Command -- {{{3
+break_passcount tracepointNumber passcount = cmd "break-passcount" $ map opt [tracepointNumber, passcount]
+
+break_watch :: Bool -> Command -- {{{3
+break_watch access = cmd "break-watch" [opt (if access then "-a" else "-r")]
+
+-- program context {{{2
+exec_arguments :: [String] -> Command -- {{{3
+exec_arguments args = cmd "exec-arguments" $ map opt args
+
+environment_cd :: String -> Command -- {{{3
+environment_cd pathdir = cmd "environment-cd" [opt pathdir]
+
+environment_directory :: Bool -> [String] -> Command -- {{{3
+environment_directory reset pathdirs = cmd "environment-directory" $ flagOpt "-r" reset ?: map opt pathdirs
+
+environment_path :: Bool -> [String] -> Command -- {{{3
+environment_path reset pathdirs = cmd "environment-path" $ flagOpt "-r" reset ?: map opt pathdirs
+
+environment_pwd :: Command -- {{{3
+environment_pwd = cmd "environment-pwd" []
+
+-- thread commands {{{2
+thread_info :: Maybe Int -> Command -- {{{3
+thread_info threadId = cmd "thread-info" $ fmap opt threadId ?: []
+
+thread_list_ids :: Command -- {{{3
+thread_list_ids = cmd "thread-list-ids" []
+
+thread_select :: Int -> Command -- {{{3
+thread_select threadnum = cmd "thread-select" [opt threadnum]
+
+-- ada tasking commands -- TODO {{{2
+
+-- program execution {{{2
+exec_continue :: Bool -> Either Bool Int -> Command -- {{{3
+exec_continue reverse x = cmd "exec-continue" $ reverse' ?: x' ?: []
+ where
+ reverse' = flagOpt "--reverse" reverse
+ x' = case x of
+ Left all -> flagOpt "--all" all
+ Right threadGroup -> Just $ opt' "--threadGroup" threadGroup
+
+exec_finish :: Bool -> Command -- {{{3
+exec_finish reverse = cmd "exec-finish" $ flagOpt "--reverse" reverse ?: []
+
+exec_interrupt :: Either Bool Int -> Command -- {{{3
+exec_interrupt x = cmd "exec-interrupt" $ x' ?: []
+ where
+ x' = case x of
+ Left all -> flagOpt "-all" all
+ Right threadGroup -> Just $ opt' "--threadGroup" threadGroup
+
+exec_jump :: Location -> Command -- {{{3
+exec_jump location = cmd "exec-jump" [opt location]
+
+exec_next :: Command -- {{{3
+exec_next = cmd "exec-next" []
+
+exec_next_instruction :: Bool -> Command -- {{{3
+exec_next_instruction reverse = cmd "exec-next-instruction" $ flagOpt "--reverse" reverse ?: []
+
+exec_return :: Command -- {{{3
+exec_return = cmd "exec-return" []
+
+exec_run :: Either Bool Int -> Command -- {{{3
+exec_run x = cmd "exec-run" $ x' ?: []
+ where
+ x' = case x of
+ Left all -> flagOpt "-all" all
+ Right threadGroup -> Just $ opt' "--threadGroup" threadGroup
+
+exec_step :: Command -- {{{3
+exec_step = cmd "exec-step" []
+
+exec_step_instruction :: Bool -> Command -- {{{3
+exec_step_instruction reverse = cmd "exec-step-instruction" $ flagOpt "--reverse" reverse ?: []
+
+exec_until :: Location -> Command -- {{{3
+exec_until location = cmd "exec-until" [opt location]
+
+-- stack manipulation {{{2
+stack_info_frame :: Command -- {{{3
+stack_info_frame = cmd "stack-info-frame" []
+
+stack_info_depth :: Maybe Int -> Command -- {{{3
+stack_info_depth maxDepth = cmd "stack-info-depth" $ fmap opt maxDepth ?: []
+
+stack_list_arguments :: PrintValues -> Maybe (Int, Int) -> Command -- {{{3
+stack_list_arguments printValues frames = cmd "stack-list-arguments" $ opt printValues : maybTupleOpt frames
+
+stack_list_arguments' :: Int -> Maybe (Int, Int) -> Command
+stack_list_arguments' = mapPrintValues stack_list_arguments
+
+stack_list_frames :: Maybe (Int, Int) -> Command -- {{{3
+stack_list_frames frames = cmd "stack-list-frames" $ maybTupleOpt frames
+
+stack_list_locals :: PrintValues -> Command -- {{{3
+stack_list_locals printValues = cmd "stack-list-locals" [opt printValues]
+
+stack_list_locals' :: Int -> Command -- {{{3
+stack_list_locals' = mapPrintValues stack_list_locals
+
+stack_list_variables :: PrintValues -> Command -- {{{3
+stack_list_variables printValues = cmd "stack-list-variable" [opt printValues]
+
+stack_list_variables' :: Int -> Command -- {{{3
+stack_list_variables' = mapPrintValues stack_list_variables
+
+stack_select_frame :: Int -> Command -- {{{3
+stack_select_frame framenum = cmd "stack-select-frame" [opt framenum]
+
+-- variable objects {{{2
+enable_pretty_printing :: Command -- {{{3
+enable_pretty_printing = cmd "enable-pretty-printing" []
+
+var_create :: Maybe String -> FrameSelect -> String -> Command -- {{{3
+var_create name frameSelect expression = cmd "var-create" $ [name', opt frameSelect, opt expression]
+ where
+ name' = opt (fromMaybe "-" name)
+
+var_delete :: Bool -> String -> Command -- {{{3
+var_delete children name = cmd "var-delete" $ flagOpt "-c" children ?: opt name : []
+
+var_set_format :: String -> FormatSpec -> Command -- {{{3
+var_set_format name formatSpec = cmd "var-set-format" [opt name, opt formatSpec]
+
+var_gdbShow_format :: String -> Command -- {{{3
+var_gdbShow_format name = cmd "var-gdbShow-format" [opt name]
+
+var_info_num_children :: String -> Command -- {{{3
+var_info_num_children name = cmd "var-info-num-children" [opt name]
+
+var_list_children :: Maybe PrintValues -> String -> Maybe (Int, Int) -> Command -- {{{3
+var_list_children Nothing name range = var_list_children (Just NoValues) name range
+var_list_children (Just printValues) name range = cmd "var-list-children" $ opt printValues : opt name : maybTupleOpt range
+
+var_list_children' :: Int -> String -> Maybe (Int, Int) -> Command
+var_list_children' = mapPrintValues (var_list_children . Just)
+
+var_info_type :: Command -- {{{3
+var_info_type = cmd "var-info-type" []
+
+var_info_expression :: String -> Command -- {{{3
+var_info_expression name = cmd "var-info-expression" [opt name]
+
+var_info_path_expressoin :: String -> Command -- {{{3
+var_info_path_expressoin name = cmd "var-info-path-expression" [opt name]
+
+var_gdbShow_attributes :: String -> Command -- {{{3
+var_gdbShow_attributes name = cmd "var-gdbShow-attributes" [opt name]
+
+var_evaluate_expression :: Maybe FormatSpec -> String -> Command -- {{{3
+var_evaluate_expression formatSpec name = cmd "var-evaluate-expression" $ valueOpt "-f" formatSpec ?: opt name : []
+
+var_assign :: String -> String -> Command -- {{{3
+var_assign name expression = cmd "var-assign" [opt name, opt expression]
+
+var_update :: Maybe PrintValues -> Maybe String -> Command -- {{{3
+var_update Nothing name = var_update (Just NoValues) name
+var_update (Just printValues) name = cmd "var-update" $ opt printValues : fmap opt name ?: []
+
+var_set_frozen :: String -> FrozenFlag -> Command -- {{{3
+var_set_frozen name flag = cmd "var-set-frozen" [opt name, opt flag]
+
+var_set_update_range :: String -> Int -> Int -> Command -- {{{3
+var_set_update_range name from to = cmd "var-set-update-range" [opt name, opt from, opt to]
+
+var_set_visualizer :: String -> String -> Command -- {{{3
+var_set_visualizer name visualizer = cmd "ver-set-visualizer" [opt name, opt visualizer]
+
+-- data manipulation {{{2
+data_disassemble :: Either (String, String) (String, Int, Maybe Int) -> DisassemblyMode -> Command -- {{{3
+data_disassemble x mode = MICommand Nothing "data-disassemble" options [QuotedString . gdbShow $ mode]
+ where
+ options = case x of
+ Left (start, end) -> opt' "-s" start : opt' "-e" end : []
+ Right (filename, linenum, lines) -> opt' "-f" filename : opt' "-l" linenum : valueOpt "-n" lines ?: []
+
+data_evaluate_expression :: String -> Command -- {{{3
+data_evaluate_expression expr = cmd "data-evaluate-expression" [opt expr]
+
+data_list_changed_registers :: Command -- {{{3
+data_list_changed_registers = cmd "data-list-changed-registers" []
+
+data_list_register_names :: [Int] -> Command -- {{{3
+data_list_register_names regnos = cmd "data-list-register-names" $ map opt regnos
+
+data_list_register_values :: DataFormat -> [Int] -> Command -- {{{3
+data_list_register_values fmt regnos = cmd "data-list-register-values" $ opt fmt : map opt regnos
+
+data_read_memory :: Maybe Int -> String -> OutputFormat -> Int -> Int -> Int -> Maybe Char -> Command -- {{{3
+data_read_memory byteOffset address wordFormat wordSize nrRows nrCols asChar =
+ cmd "data-read-memory" $ valueOpt "-o" byteOffset ?: opt address : opt wordFormat : opt wordSize : opt nrRows : opt nrCols : fmap opt asChar ?: []
+
+data_read_memory_bytes :: Maybe Int -> String -> Int -> Command -- {{{3
+data_read_memory_bytes byteOffset address count = cmd "data-read-memory-bytes" $ valueOpt "-o" byteOffset ?: opt address : opt count : []
+
+data_write_memory_bytes :: String -> String -> Command -- {{{3
+data_write_memory_bytes address contents = cmd "data-write-memory-bytes" [opt address, opt contents]
+
+-- tracepoint commands {{{2
+trace_find :: TraceMode -> Command -- {{{3
+trace_find traceMode = cmd "trace-find" $ opt traceMode : traceModeOptions traceMode
+
+trace_define_variable :: String -> Maybe String -> Command -- {{{3
+trace_define_variable name value = cmd "trace-define-variable" $ opt name : fmap opt value ?: []
+
+trace_list_variables :: Command -- {{{3
+trace_list_variables = cmd "trace-list-variables" []
+
+trace_save :: Bool -> String -> Command -- {{{3
+trace_save remote filename = cmd "trace-save" $ flagOpt "-r" remote ?: opt filename : []
+
+trace_start :: Command -- {{{3
+trace_start = cmd "trace-start" []
+
+trace_status :: Command -- {{{3
+trace_status = cmd "trace-status" []
+
+trace_stop :: Command -- {{{3
+trace_stop = cmd "trace-stop" []
+
+-- symbol query {{{2
+
+symbol_list_lines :: String -> Command -- {{{3
+symbol_list_lines filename = cmd "symbol-list-lines" [opt filename]
+
+-- file commands {{{2
+file_exec_and_symbols :: Maybe FilePath -> Command -- {{{3
+file_exec_and_symbols file = cmd "file-exec-and-symbols" $ fmap opt file ?: []
+
+file_exec_file :: Maybe FilePath -> Command -- {{{3
+file_exec_file file = cmd "file-exec-file" $ fmap opt file ?: []
+
+file_list_exec_source_file :: Command -- {{{3
+file_list_exec_source_file = cmd "file-list-exec-source-file" []
+
+file_list_exec_source_files :: Command -- {{{3
+file_list_exec_source_files = cmd "file-list-exec-source-files" []
+
+file_symbol_file :: Maybe FilePath -> Command -- {{{3
+file_symbol_file file = cmd "file-symbol-file" $ fmap opt file ?: []
+
+-- target manipulation {{{2
+target_attach :: Either Int FilePath -> Command -- {{{3
+target_attach x = cmd "target-attach" $ x' : []
+ where
+ x' = case x of
+ Left pidOrGid -> opt pidOrGid
+ Right file -> opt file
+
+target_detach :: Maybe Int -> Command -- {{{3
+target_detach pidOrGid = cmd "target-detach" $ fmap opt pidOrGid ?: []
+
+target_disconnect :: Command -- {{{3
+target_disconnect = cmd "target-disconnect" []
+
+target_download :: Command -- {{{3
+target_download = cmd "target-download" []
+
+target_select :: Target -> Command -- {{{3
+target_select target = cmd "target-select" $ opt target : targetOptions target
+
+-- file transfer commands {{{2
+target_file_put :: FilePath -> FilePath -> Command -- {{{3
+target_file_put hostfile targetfile = cmd "target-file-put" $ opt hostfile : opt targetfile : []
+
+target_file_get :: FilePath -> FilePath -> Command -- {{{3
+target_file_get targetfile hostfile = cmd "target-file-get" $ opt targetfile : opt hostfile : []
+
+target_file_delete :: FilePath -> Command -- {{{3
+target_file_delete targetfile = cmd "target-file-delete" $ opt targetfile : []
+
+-- miscellaneous commmands {{{2
+gdb_exit :: Command -- {{{3
+gdb_exit = cmd "gdb-exit" []
+
+gdb_set :: String -> Command -- {{{3
+gdb_set expr = cmd "gdb-set" $ opt expr : []
+
+gdb_gdbShow :: String -> Command -- {{{3
+gdb_gdbShow name = cmd "gdb-gdbShow" $ opt name : []
+
+gdb_version :: Command -- {{{3
+gdb_version = cmd "gdb-version" []
+
+list_features :: Command -- {{{3
+list_features = cmd "list-features" []
+
+list_target_features :: Command -- {{{3
+list_target_features = cmd "list-target-features" []
+
+list_thread_groups :: Bool -> Maybe Int -> [Int] -> Command -- {{{3
+list_thread_groups available recurse groups = cmd "list-thread-groups" $ flagOpt "--available" available ?: valueOpt "--recurse" recurse ?: map opt groups
+
+info_os :: Maybe String -> Command -- {{{3
+info_os type_ = cmd "info-os" $ fmap opt type_ ?: []
+
+add_inferior :: Command -- {{{3
+add_inferior = cmd "add-inferior" []
+
+interpreter_exec :: Interpreter -> Command -> Command -- {{{3
+interpreter_exec interpreter command = cmd "interpreter-exec" $ opt interpreter : opt ((escapeQuotes . render_command) command) : []
+
+inferior_tty_set :: String -> Command -- {{{3
+inferior_tty_set tty = cmd "inferior-tty-set" $ opt tty : []
+
+inferior_tty_gdbShow :: Command -- {{{3
+inferior_tty_gdbShow = cmd "inferior-tty-gdbShow" []
+
+enable_timings :: Bool -> Command -- {{{3
+enable_timings flag = cmd "enable-timings" $ opt (if flag then "yes" else "no") : []
+
+-- utils {{{1
+cmd :: String -> [Option] -> Command -- {{{2
+cmd operation options = MICommand Nothing operation options []
+
+opt :: GdbShow a => a -> Option -- {{{2
+opt parameter = Option (QuotedString . gdbShow $ parameter) Nothing
+
+optr :: Show a => a -> Option -- {{{2
+optr parameter = Option (RawString . show $ parameter) Nothing
+
+opt' :: (GdbShow a, GdbShow b) => a -> b -> Option -- {{{2
+opt' name value = Option (QuotedString . gdbShow $ name) (Just (QuotedString . gdbShow $ value))
+
+flagOpt :: String -> Bool -> Maybe Option -- {{{2
+flagOpt _ False = Nothing
+flagOpt flag True = Just (opt flag)
+
+valueOpt :: GdbShow a => String -> Maybe a -> Maybe Option -- {{{2
+valueOpt _ Nothing = Nothing
+valueOpt flag param = Just (Option (QuotedString flag) (fmap (QuotedString . gdbShow) param))
+
+maybTupleOpt :: GdbShow a => Maybe (a, a) -> [Option] -- {{{2
+maybTupleOpt Nothing = []
+maybTupleOpt (Just (lowFrame, highFrame)) = map opt [lowFrame, highFrame]
+
+(?:) :: Maybe a -> [a] -> [a] -- {{{1
+(Just x) ?: xs = x : xs
+Nothing ?: xs = xs
+infixr 5 ?:
+
+escapeQuotes :: String -> String -- {{{2
+escapeQuotes = replace '"' "\\\""
+
+replace :: Char -> String -> String -> String -- {{{2
+replace old new = join new . split old
+ where
+ join delim l = concat (intersperse delim l)
+ split _ [] = []
+ split c str =
+ let (str', rest) = break (==c) str in
+ if null rest
+ then [str']
+ else str' : split c (tail rest)
View
187 src/Gdbmi/IO.hs
@@ -0,0 +1,187 @@
+module Gdbmi.IO
+-- exports {{{1
+(
+ Context, Callback(..)
+ , setup, shutdown, send_command
+) where
+
+-- imports {{{1
+import Control.Applicative ((<*>), (<$>))
+import Control.Concurrent (forkIO, killThread, ThreadId, MVar, newEmptyMVar, tryTakeMVar, putMVar, takeMVar)
+import Control.Concurrent.STM (TVar, TChan, TMVar, newEmptyTMVar, newTVarIO, newTChanIO, atomically, takeTMVar, readTVar, writeTVar, writeTChan, readTChan, putTMVar)
+import Control.Exception (catchJust)
+import Control.Exception.Base (AsyncException(ThreadKilled))
+import Control.Monad (replicateM_)
+import Control.Monad.Fix (mfix)
+import Data.List (partition)
+import Prelude hiding (catch, interact)
+import System.IO (Handle, hSetBuffering, BufferMode(LineBuffering), hPutStr, hWaitForInput, hGetLine, IOMode(WriteMode), stdout, openFile, hFlush)
+import System.Posix.IO (fdToHandle, createPipe)
+import System.Process (ProcessHandle, runProcess, waitForProcess)
+
+import qualified Gdbmi.Commands as C
+import qualified Gdbmi.Representation as R
+import qualified Gdbmi.Responses as S
+
+data Context = Context { -- {{{1
+-- gdb process {{{2
+ ctxProcess :: ProcessHandle
+ , ctxCommandPipe :: Handle
+ , ctxOutputPipe :: Handle
+ , ctxLog :: Maybe Handle
+-- callback
+ , ctxCallback :: Callback
+-- threads
+ , ctxCommandThread :: ThreadId
+ , ctxOutputThread :: ThreadId
+ , ctxCurrentJob :: MVar Job
+ , ctxFinished :: MVar ()
+-- jobs
+ , ctxNextToken :: TVar R.Token
+ , ctxJobs :: TChan Job
+}
+
+data Job = Job {
+ jobCommand :: R.Command
+ , jobResponse :: TMVar R.Response
+ , jobToken :: R.Token
+ }
+
+data Callback -- {{{1
+ = Callback {
+ cbStream :: R.Stream -> IO ()
+ , cbStopped :: S.Stopped -> IO ()
+ , cbNotify :: R.Notification -> IO ()
+ }
+
+setup :: Maybe FilePath -> Callback -> IO Context -- {{{1
+setup logfile callback = do
+ (commandR, commandW) <- createPipe >>= asHandles
+ (outputR, outputW) <- createPipe >>= asHandles
+ phandle <- runProcess "setsid" (words "schroot -c quantal -p -- gdb --interpreter mi") -- avoid receiving SIGINTs when issuing -exec-interrupt
+ Nothing Nothing
+ (Just commandR)
+ (Just outputW)
+ Nothing
+ mapM_ (`hSetBuffering` LineBuffering) [commandW, outputR]
+ logH <- case logfile of
+ Nothing -> return Nothing
+ Just "-" -> return $ Just stdout
+ Just f -> fmap Just $ openFile f WriteMode
+ currentJob <- newEmptyMVar
+ finished <- newEmptyMVar
+ nextToken <- newTVarIO 0
+ jobs <- newTChanIO
+ ctx <- mfix (\ctx -> do
+ itid <- forkIO (handleCommands ctx)
+ otid <- forkIO (handleOutput ctx)
+ return $ Context phandle commandW outputR logH callback itid otid currentJob finished nextToken jobs
+ )
+ return ctx
+ where
+ asHandles (f1, f2) = do
+ h1 <- fdToHandle f1
+ h2 <- fdToHandle f2
+ return (h1, h2)
+
+shutdown :: Context -> IO () -- {{{1
+shutdown ctx = do
+ mapM_ (killThread . ($ctx)) [ctxCommandThread, ctxOutputThread]
+ replicateM_ 2 (takeMVar (ctxFinished ctx))
+ writeCommand ctx C.gdb_exit 0
+ _ <- waitForProcess (ctxProcess ctx)
+ putMVar (ctxFinished ctx) ()
+ return ()
+
+send_command :: Context -> R.Command -> IO R.Response -- {{{1
+send_command ctx command = checkShutdown >> sendCommand >>= receiveResponse
+ where
+ checkShutdown = do
+ finished <- tryTakeMVar (ctxFinished ctx)
+ case finished of
+ Nothing -> return ()
+ Just () -> error "context has already been shut down"
+
+ sendCommand = atomically $ do
+ token <- readTVar (ctxNextToken ctx)
+ writeTVar (ctxNextToken ctx) (if token == maxBound then 0 else token + 1)
+ response <- newEmptyTMVar
+ writeTChan (ctxJobs ctx) $ Job command response token
+ return response
+
+ receiveResponse = atomically . takeTMVar
+
+
+-- implementation {{{1
+handleCommands :: Context -> IO () -- {{{2
+handleCommands ctx = handleKill ctx $ do
+ job <- atomically $ readTChan (ctxJobs ctx)
+ putMVar (ctxCurrentJob ctx) job
+ writeCommand ctx (jobCommand job) (jobToken job)
+ handleCommands ctx
+
+handleOutput :: Context -> IO () -- {{{2
+handleOutput ctx = handleKill ctx $ do
+ output <- readOutput ctx
+ _ <- forkIO $
+ let
+ streams = R.output_stream output
+ notifications = R.output_notification output
+ (stops, others) = partition ((&&) <$> (R.Exec==) . R.notiClass <*> (R.ACStop==) . R.notiAsyncClass) notifications
+ Just stops' = sequence $ map (S.response_stopped . R.notiResults) stops
+ in do
+ mapM_ ((cbStream . ctxCallback) ctx) streams
+ mapM_ ((cbNotify . ctxCallback) ctx) others
+ mapM_ ((cbStopped . ctxCallback) ctx) stops'
+ case R.output_response output of
+ Nothing -> return ()
+ Just response -> do
+ maybJob <- tryTakeMVar (ctxCurrentJob ctx)
+ case maybJob of
+ Nothing -> error "result record lost!"
+ Just job ->
+ if (R.get_token output /= Just (jobToken job))
+ then error $ "token missmatch! " ++ show (R.get_token output) ++ " vs. " ++ show (jobToken job)
+ else atomically $ putTMVar (jobResponse job) response
+ handleOutput ctx
+
+handleKill :: Context -> IO () -> IO ()
+handleKill ctx action = catchJust select action handler
+ where
+ select :: AsyncException -> Maybe ()
+ select ThreadKilled = Just ()
+ select _ = Nothing
+
+ handler :: () -> IO ()
+ handler _ = putMVar (ctxFinished ctx) ()
+
+writeCommand :: Context -> R.Command -> R.Token -> IO () -- {{{2
+writeCommand ctx cmd token =
+ let cmdstr = (R.render_command . C.add_token token) cmd in
+ do
+ debugLog ctx True cmdstr
+ hPutStr (ctxCommandPipe ctx) cmdstr
+
+readOutput :: Context -> IO R.Output -- {{{2
+readOutput ctx = do
+ _ <- hWaitForInput (ctxOutputPipe ctx) (-1)
+ str <- outputString (ctxOutputPipe ctx)
+ debugLog ctx False str
+ return (R.parse_output str)
+ where
+ outputString handle = outputLines handle >>= return . unlines
+ outputLines handle = do
+ line <- hGetLine handle
+ if line == "(gdb) "
+ then return [line]
+ else outputLines handle >>= return . (line:)
+
+debugLog :: Context -> Bool -> String -> IO () -- {{{2
+debugLog ctx io text =
+ let
+ prefix = if io then "/i " else "/o "
+ line = ((unlines . map (prefix++) . lines) text)
+ in
+ case (ctxLog ctx) of
+ Nothing -> return ()
+ Just h -> hPutStr h line >> hFlush h
View
442 src/Gdbmi/Representation.hs
@@ -0,0 +1,442 @@
+module Gdbmi.Representation where
+
+-- imports {{{1
+import Control.Applicative ((<$>), (<*>), (<*))
+import Data.Char (isAscii)
+import Data.List (find)
+import Data.Maybe (isNothing)
+import Text.ParserCombinators.Parsec hiding (token)
+
+-- input {{{1
+-- types {{{2
+data Command -- {{{3
+ = CLICommand (Maybe Token) String
+ | MICommand (Maybe Token) Operation [Option] [Parameter]
+
+type Operation = String -- {{{3
+
+data Option = Option Parameter (Maybe Parameter) -- {{{3
+
+data Parameter -- {{{3
+ -- the documentation does not specify this, but de-facto some parameters have
+ -- to be quoted and other must not
+ = RawString String
+ | QuotedString String
+
+-- rendering {{{2
+render_command :: Command -> String -- {{{3
+render_command cmd = r_command cmd ""
+
+r_command :: Command -> ShowS -- {{{3
+r_command (CLICommand tok str) = maybe id r_token tok . showString str . showString "\n"
+r_command (MICommand tok operation options parameters) =
+ maybe id shows tok
+ . showString "-" . r_operation operation
+ . foldl (\f o -> f . showString " " . r_option o) id options
+ . (if null parameters
+ then id
+ else showString " --" . foldl (\f p -> f . showString " " . r_parameter p) id parameters)
+ . showString "\n"
+
+r_operation :: Operation -> ShowS -- {{{3
+r_operation op = (op++)
+
+r_option :: Option -> ShowS -- {{{3
+ -- the documentation specifies a "-" before each option but some operations
+ -- such as file-exec-and-symbols are not happy with this :-/
+r_option (Option p p') =
+ r_parameter p
+ . maybe id (\x -> showString " " . r_parameter x) p'
+
+r_parameter :: Parameter -> ShowS -- {{{3
+r_parameter (RawString s) = showString s
+r_parameter (QuotedString s) = shows s
+
+r_token :: Token -> ShowS -- {{{3
+r_token = shows
+
+-- output {{{1
+-- types {{{2
+data Output -- {{{3
+ = Output [OutOfBandRecord] (Maybe ResultRecord)
+ deriving Show
+
+data ResultRecord -- {{{3
+ = ResultRecord (Maybe Token) ResultClass [Result]
+ deriving Show
+
+data OutOfBandRecord -- {{{3
+ = OOBAsyncRecord AsyncRecord
+ | OOBStreamRecord StreamRecord
+ deriving Show
+
+data AsyncRecord -- {{{3
+ = ARExecAsyncOutput ExecAsyncOutput
+ | ARStatusAsyncOutput StatusAsyncOutput
+ | ARNotifyAsyncOutput NotifyAsyncOutput
+ deriving Show
+
+data ExecAsyncOutput -- {{{3
+ = ExecAsyncOutput (Maybe Token) AsyncOutput
+ deriving Show
+
+data StatusAsyncOutput -- {{{3
+ = StatusAsyncOutput (Maybe Token) AsyncOutput
+ deriving Show
+
+data NotifyAsyncOutput -- {{{3
+ = NotifyAsyncOutput (Maybe Token) AsyncOutput
+ deriving Show
+
+data AsyncOutput -- {{{3
+ = AsyncOutput AsyncClass [Result]
+ deriving Show
+
+data ResultClass -- {{{3
+ = RCDone
+ | RCRunning
+ | RCConnected
+ | RCError
+ | RCExit
+ deriving (Show, Eq)
+
+data AsyncClass -- {{{3
+-- much more stuff than the documentation specifies
+ = ACStop
+ | ACThreadGroupAdded
+ | ACThreadGroupStarted
+ | ACThreadCreated
+ | ACRunning
+ | ACLibraryLoaded
+ | ACThreadExited
+ | ACThreadGroupExited
+ | ACBreakpointModified
+ deriving (Show, Eq)
+
+data Result -- {{{3
+ = Result {
+ resVariable :: Variable
+ , resValue :: Value
+ }
+ deriving Show
+
+type Variable = String -- {{{3
+
+data Value -- {{{3
+ = VConst Const
+ | VTuple Tuple
+ | VList List
+ deriving Show
+
+type Const = CString -- {{{3
+
+data Tuple -- {{{3
+ = Tuple {
+ tupleResults :: [Result]
+ }
+ deriving Show
+
+data List -- {{{3
+ = EmptyList
+ | ValueList [Value]
+ | ResultList [Result]
+ deriving Show
+
+data StreamRecord -- {{{3
+ = SRConsoleStreamOutput ConsoleStreamOutput
+ | SRTargetStreamOutput TargetStreamOutput
+ | SRLogStreamOutput LogStreamOutput
+ deriving Show
+
+data ConsoleStreamOutput -- {{{3
+ = ConsoleStreamOutput CString
+ deriving Show
+
+data TargetStreamOutput -- {{{3
+ = TargetStreamOutput CString
+ deriving Show
+
+data LogStreamOutput -- {{{3
+ = LogStreamOutput CString
+ deriving Show
+
+type CString = String -- {{{3
+
+-- parsing {{{2
+parse_output :: String -> Output -- {{{3
+parse_output str = case parse p_output "gdb" str of
+ Left pe -> error $ "parse failed: " ++ show pe
+ Right o -> o
+
+p_output :: Parser Output -- {{{3
+-- http://sourceware.org/bugzilla/show_bug.cgi?id=7708
+-- p_output = Output <$> many p_outOfBandRecord <*> optionMaybe p_resultRecord <* string "(gdb) " <* newline <* eof
+p_output = do
+ oob <- many p_outOfBandRecord
+ rr <- optionMaybe p_resultRecord
+ oob' <- many p_outOfBandRecord
+ string "(gdb) " >> newline >> eof
+ return $ Output (oob ++ oob') rr
+
+p_resultRecord :: Parser ResultRecord -- {{{3
+p_resultRecord =
+ ResultRecord <$> optionMaybe p_token <* char '^' <*> p_resultClass <*> many (char ',' >> p_result) <* newline
+
+p_outOfBandRecord :: Parser OutOfBandRecord -- {{{3
+p_outOfBandRecord =
+ try (p_asyncRecord >>= return . OOBAsyncRecord)
+ <|> (p_streamRecord >>= return . OOBStreamRecord)
+
+p_asyncRecord :: Parser AsyncRecord -- {{{3
+p_asyncRecord =
+ (p_execAsyncOutput >>= return . ARExecAsyncOutput)
+ <|> (p_statusAsyncOutput >>= return . ARStatusAsyncOutput)
+ <|> (p_notifyAsyncOutput >>= return . ARNotifyAsyncOutput)
+
+p_execAsyncOutput :: Parser ExecAsyncOutput -- {{{3
+p_execAsyncOutput =
+ ExecAsyncOutput <$> optionMaybe p_token <* char '*' <*> p_asyncOutput
+
+p_statusAsyncOutput :: Parser StatusAsyncOutput -- {{{3
+p_statusAsyncOutput =
+ StatusAsyncOutput <$> optionMaybe p_token <* char '+' <*> p_asyncOutput
+
+p_notifyAsyncOutput :: Parser NotifyAsyncOutput -- {{{3
+p_notifyAsyncOutput =
+ NotifyAsyncOutput <$> optionMaybe p_token <* char '=' <*> p_asyncOutput
+
+p_asyncOutput :: Parser AsyncOutput -- {{{3
+p_asyncOutput =
+ AsyncOutput <$> p_asyncClass <*> many (char ',' >> p_result) <* newline
+
+p_resultClass :: Parser ResultClass -- {{{3
+p_resultClass =
+ try (string "done" >> return RCDone)
+ <|> try (string "running" >> return RCRunning)
+ <|> try (string "connected" >> return RCConnected)
+ <|> try (string "error" >> return RCError)
+ <|> (string "exit" >> return RCExit)
+
+p_asyncClass :: Parser AsyncClass -- {{{3
+p_asyncClass =
+ try (string "stopped" >> return ACStop)
+ <|> try (string "thread-group-added" >> return ACThreadGroupAdded)
+ <|> try (string "thread-group-started" >> return ACThreadGroupStarted)
+ <|> try (string "thread-created" >> return ACThreadCreated)
+ <|> try (string "running" >> return ACRunning)
+ <|> try (string "thread-exited" >> return ACThreadExited)
+ <|> try (string "thread-group-exited" >> return ACThreadGroupExited)
+ <|> try (string "breakpoint-modified" >> return ACBreakpointModified)
+ <|> (string "library-loaded" >> return ACLibraryLoaded)
+
+p_result :: Parser Result -- {{{3
+p_result =
+ Result <$> p_variable <* char '=' <*> p_value
+
+p_variable :: Parser Variable -- {{{3
+p_variable = many1 (letter <|> digit <|> oneOf "_-")
+
+p_value :: Parser Value -- {{{3
+p_value =
+ (p_const >>= return . VConst)
+ <|> (p_tuple >>= return . VTuple)
+ <|> (p_list >>= return . VList)
+
+p_const :: Parser Const -- {{{3
+p_const = p_cString
+
+p_tuple :: Parser Tuple -- {{{3
+p_tuple = try p_emptyTuple <|> p_filledTuple
+ where
+ p_emptyTuple = string "{}" >> return (Tuple [])
+ p_filledTuple = do
+ _ <- char '{'
+ first <- p_result
+ rest <- many (char ',' >> p_result)
+ _ <- char '}'
+ return $ Tuple (first:rest)
+
+p_list :: Parser List -- {{{3
+p_list = try p_emptyList <|> try p_valueList <|> p_resultList
+ where
+ p_emptyList = string "[]" >> return EmptyList
+ p_valueList = do
+ _ <- char '['
+ first <- p_value
+ rest <- many (char ',' >> p_value)
+ _ <- char ']'
+ return $ ValueList (first:rest)
+
+ p_resultList = do
+ _ <- char '['
+ first <- p_result
+ rest <- many (char ',' >> p_result)
+ _ <- char ']'
+ return $ ResultList (first:rest)
+
+p_streamRecord :: Parser StreamRecord -- {{{3
+p_streamRecord = do
+ sr <- anyStreamRecord
+ _ <- newline -- the documentation does not specifiy this newline, but this is what GDB is doing
+ return sr
+ where
+ anyStreamRecord =
+ (p_consoleStreamOutput >>= return . SRConsoleStreamOutput)
+ <|> (p_targetStreamOutput >>= return . SRTargetStreamOutput)
+ <|> (p_logStreamOutput >>= return . SRLogStreamOutput)
+
+p_consoleStreamOutput :: Parser ConsoleStreamOutput -- {{{3
+p_consoleStreamOutput = char '~' >> p_cString >>= return . ConsoleStreamOutput
+
+p_targetStreamOutput :: Parser TargetStreamOutput -- {{{3
+p_targetStreamOutput = char '@' >> p_cString >>= return . TargetStreamOutput
+
+p_logStreamOutput :: Parser LogStreamOutput -- {{{3
+p_logStreamOutput = char '&' >> p_cString >>= return . LogStreamOutput
+
+p_cString :: Parser CString -- {{{3
+p_cString = between (char '"') (char '"') (many p_cchar)
+ where
+ p_cchar = p_cbackslash
+ <|> noneOf "\""
+ p_cbackslash = do
+ _ <- char '\\'
+ c <- anyChar
+ case c of
+ '\\' -> return '\\'
+ 'n' -> return '\n'
+ '"' -> return '"'
+ _ -> fail $ "unknown backslash escape: " ++ show c
+
+p_token :: Parser Token -- {{{3
+p_token = many1 digit >>= return . read
+
+-- simplification {{{1
+data Response -- {{{2
+ = Response {
+ respClass :: ResultClass
+ , respResults :: [Result]
+ }
+ deriving (Show)
+
+data Notification -- {{{2
+ = Notification {
+ notiClass :: NotificationClass
+ , notiAsyncClass :: AsyncClass
+ , notiResults :: [Result]
+ }
+ deriving Show
+
+data NotificationClass -- {{{3
+ = Exec
+ | Status
+ | Notify
+ deriving (Show, Eq)
+
+data Stream -- {{{2
+ = Stream StreamClass String
+ deriving Show
+
+data StreamClass -- {{{3
+ = Console
+ | Target
+ | Log
+ deriving Show
+
+output_response :: Output -> Maybe Response -- {{{2
+output_response (Output _ Nothing) = Nothing
+output_response (Output _ (Just (ResultRecord _ rc rs))) = Just $ Response rc rs
+
+output_notification :: Output -> [Notification] -- {{{2
+output_notification (Output oobs _) = map (notification . unp) $ filter isNotification oobs
+ where
+ isNotification (OOBAsyncRecord _) = True
+ isNotification _ = False
+
+ unp (OOBAsyncRecord x) = x
+ unp x = error $ "unexpected parameter: " ++ show x
+
+ notification (ARExecAsyncOutput (ExecAsyncOutput _ (AsyncOutput ac rs))) = Notification Exec ac rs
+ notification (ARStatusAsyncOutput (StatusAsyncOutput _ (AsyncOutput ac rs))) = Notification Status ac rs
+ notification (ARNotifyAsyncOutput (NotifyAsyncOutput _ (AsyncOutput ac rs))) = Notification Notify ac rs
+
+output_stream :: Output -> [Stream] -- {{{2
+output_stream (Output oobs _) = map (stream . unp) $ filter isStream oobs
+ where
+ isStream (OOBStreamRecord _) = True
+ isStream _ = False
+
+ unp (OOBStreamRecord x) = x
+ unp x = error $ "unexpected parameter: " ++ show x
+
+ stream (SRConsoleStreamOutput (ConsoleStreamOutput s)) = Stream Console s
+ stream (SRTargetStreamOutput (TargetStreamOutput s)) = Stream Target s
+ stream (SRLogStreamOutput (LogStreamOutput s)) = Stream Log s
+
+-- utils {{{2
+asConst :: Value -> Maybe Const -- {{{2
+asConst (VConst x) = Just x
+asConst _ = Nothing
+
+asTuple :: Value -> Maybe Tuple -- {{{2
+asTuple (VTuple x) = Just x
+asTuple _ = Nothing
+
+asList :: Value -> Maybe List -- {{{2
+asList (VList x) = Just x
+asList _ = Nothing
+
+-- token {{{1
+type Token = Int
+
+class GetToken a where
+ get_token :: a -> Maybe Token
+
+instance GetToken ResultRecord where
+ get_token (ResultRecord token _ _) = token
+
+instance GetToken Command where
+ get_token (CLICommand token _) = token
+ get_token (MICommand token _ _ _) = token
+
+instance GetToken Output where
+ get_token (Output _ (Just r)) = get_token r
+ get_token _ = Nothing
+
+instance GetToken OutOfBandRecord where
+ get_token (OOBAsyncRecord r) = get_token r
+ get_token (OOBStreamRecord _) = Nothing
+
+instance GetToken AsyncRecord where
+ get_token (ARExecAsyncOutput x) = get_token x
+ get_token (ARStatusAsyncOutput x) = get_token x
+ get_token (ARNotifyAsyncOutput x) = get_token x
+
+instance GetToken ExecAsyncOutput where
+ get_token (ExecAsyncOutput token _) = token
+
+instance GetToken StatusAsyncOutput where
+ get_token (StatusAsyncOutput token _) = token
+
+instance GetToken NotifyAsyncOutput where
+ get_token (NotifyAsyncOutput token _) = token
+
+-- utils {{{1
+parameter_valid :: Parameter -> Bool -- {{{2
+parameter_valid (RawString s) = validParam s
+parameter_valid (QuotedString s) = validParam s
+
+validParam :: String -> Bool
+validParam param
+ | null param = False
+ | isCString param = isNothing $ find (not . isAscii) param
+ | otherwise = isNothing $ find isSpecial param
+ where
+ isCString ('"':rest) = last rest == '"'
+ isCString _ = False
+
+ isSpecial ' ' = True
+ isSpecial '-' = True
+ isSpecial '\n' = True
+ isSpecial '"' = True
+ isSpecial _ = False
View
195 src/Gdbmi/Responses.hs
@@ -0,0 +1,195 @@
+module Gdbmi.Responses where
+
+-- import {{{1
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (guard, msum, (<=<))
+import Data.List (find)
+import Gdbmi.Representation
+
+-- types {{{1
+type BkptNumber = Int
+data Breakpoint = Breakpoint { -- {{{2
+ bkptNumber :: BkptNumber
+ , bkptType :: BreakpointType
+ , bkptDisp :: BreakpointDisp
+ , bkptEnabled :: Bool
+ , bkptAddress :: String
+ , bkptFunc :: String
+ , bkptFile :: String
+ , bkptFullname :: String
+ , bkptLine :: Int
+ , bkptTimes :: Int
+ , bkptOriginalLocation :: String
+ }
+ deriving Show
+
+type BreakpointType = String -- {{{2
+
+data BreakpointDisp -- {{{2
+ = BreakpointKeep
+ | BreakpointDel
+ deriving Show
+
+instance Read BreakpointDisp where
+ readsPrec _ "del" = [(BreakpointDel, "")]
+ readsPrec _ "keep" = [(BreakpointKeep, "")]
+ readsPrec _ _ = []
+
+newtype Stack -- {{{2
+ = Stack {stackFrames :: [Frame] }
+ deriving Show
+
+data Frame = Frame { -- {{{2
+ frameLevel :: Maybe Int
+ , frameAddr :: String
+ , frameFunc :: String
+ , frameArgs :: Maybe [Arg]
+ , frameFile :: String
+ , frameFullname :: Maybe String
+ , frameLine :: Int
+ } deriving Show
+
+data Stopped = Stopped { -- {{{2
+ stoppedReason :: StopReason
+ , stoppedFrame :: Frame
+ , stoppedThreadId :: Int
+ , stoppedThreads :: String
+ , stoppedCore :: Int
+ }
+ deriving Show
+
+data StopReason -- {{{2
+ = BreakpointHit {
+ bkptHitDisp :: BreakpointDisp
+ , bkptHitNumber :: BkptNumber
+ }
+ | EndSteppingRange
+ | FunctionFinished
+
+ deriving Show
+
+data Arg = Arg { -- {{{2
+ argName :: String
+ , argValue :: String
+ } deriving Show
+
+-- composition {{{1
+responseBreakpoint :: Result -> Maybe Breakpoint -- {{{2
+responseBreakpoint (Result variable value) = do
+ guard (variable == "bkpt")
+ (Tuple rs) <- asTuple value
+ Breakpoint
+ <$> get rs tryRead "number"
+ <*> get rs Just "type"
+ <*> get rs tryRead "disp"
+ <*> get rs gdbBool "enabled"
+ <*> get rs Just "addr"
+ <*> get rs Just "func"
+ <*> get rs Just "file"
+ <*> get rs Just "fullname"
+ <*> get rs tryRead "line"
+ <*> get rs tryRead "times"
+ <*> get rs Just "original-location"
+
+responseStack :: Result -> Maybe Stack -- {{{2
+responseStack (Result variable value) = do
+ guard (variable == "stack")
+ list <- asList value
+ case list of
+ EmptyList -> Just $ Stack []
+ ResultList is ->
+ Stack <$> mapM responseFrame is
+ _ -> Nothing
+
+responseFrame :: Result -> Maybe Frame -- {{{2
+responseFrame (Result variable value) = do
+ guard (variable == "frame")
+ (Tuple rs) <- asTuple value
+ Frame
+ <$> Just (get rs tryRead "level")
+ <*> get rs Just "addr"
+ <*> get rs Just "func"
+ <*> Just (msum (map responseArgs rs))
+ <*> get rs Just "file"
+ <*> Just (get rs Just "fullname")
+ <*> get rs tryRead "line"
+
+responseStopped :: [Result] -> Maybe Stopped -- {{{2
+responseStopped rs = do
+ Stopped
+ <$> responseStopReason rs
+ <*> msum (map responseFrame rs)
+ <*> get rs tryRead "thread-id"
+ <*> get rs Just "stopped-threads"
+ <*> get rs tryRead "core"
+
+responseStopReason :: [Result] -> Maybe StopReason -- {{{2
+responseStopReason rs = do
+ reason <- find (("reason"==) . resVariable) rs >>= asConst . resValue
+ case reason of
+ "breakpoint-hit" ->
+ BreakpointHit
+ <$> get rs tryRead "disp"
+ <*> get rs tryRead "bkptno"
+ "end-stepping-range" -> Just EndSteppingRange
+ "function-finished" -> Just FunctionFinished
+ _ -> Nothing
+
+responseArgs :: Result -> Maybe [Arg] -- {{{2
+responseArgs (Result variable value) = do
+ guard (variable == "args")
+ list <- asList value
+ case list of
+ EmptyList -> Just []
+ ValueList is -> do
+ mapM ((responseArg . tupleResults) <=< asTuple) is
+ _ -> Nothing
+
+responseArg :: [Result] -> Maybe Arg -- {{{2
+responseArg rs = do
+ Arg
+ <$> get rs Just "name"
+ <*> get rs Just "value"
+
+-- responses {{{1
+response_stack_list_frames :: [Result] -> Maybe Stack -- {{{2
+response_stack_list_frames [item] = responseStack item
+response_stack_list_frames _ = Nothing
+
+response_break_insert :: [Result] -> Maybe Breakpoint -- {{{2
+response_break_insert [item] = responseBreakpoint item
+response_break_insert _ = Nothing
+
+response_data_evaluate_expression :: [Result] -> Maybe String -- {{{2
+response_data_evaluate_expression [(Result variable value)] = do
+ guard (variable == "value")
+ asConst value
+
+response_data_evaluate_expression _ = Nothing -- {{{2
+
+response_error :: [Result] -> Maybe String -- {{{2
+response_error [(Result variable value)] = do
+ guard (variable == "msg")
+ asConst value
+response_error _ = Nothing
+
+response_stopped :: [Result] -> Maybe Stopped -- {{{2
+response_stopped items = responseStopped items
+
+response_exec_return :: [Result] -> Maybe Frame -- {{{2
+response_exec_return [item] = responseFrame item
+response_exec_return _ = Nothing
+
+-- utils {{{1
+get :: [Result] -> (String -> Maybe a) -> (String -> Maybe a) -- {{{2
+get rs parse key = find ((key==) . resVariable) rs >>= asConst . resValue >>= parse
+
+tryRead :: Read a => String -> Maybe a -- {{{2
+tryRead str = case readsPrec 0 str of
+ [(x, "")] -> Just x
+ _ -> Nothing
+
+gdbBool :: String -> Maybe Bool -- {{{2
+gdbBool "y" = Just True
+gdbBool "n" = Just False
+gdbBool _ = Nothing
View
20 tests/Lib.hs
@@ -0,0 +1,20 @@
+module Lib where
+
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.TH (stringE)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.Framework (testGroup, Test)
+import Test.HUnit (Assertion)
+import Text.Printf (printf)
+
+paste :: QuasiQuoter
+paste = QuasiQuoter {
+ quoteExp = stringE,
+ quotePat = undefined,
+ quoteType = undefined,
+ quoteDec = undefined
+ }
+
+enumTestGroup :: String -> [Assertion] -> Test
+enumTestGroup name =
+ testGroup name . zipWith (testCase . printf "%.2d") [(1 :: Int)..]
View
340 tests/pure.hs
@@ -0,0 +1,340 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main (main) where
+
+-- imports {{{1
+import Gdbmi.Representation
+import Gdbmi.Responses
+import Lib (enumTestGroup, paste)
+import Test.Framework (Test, defaultMain)
+import Test.HUnit ((@=?), Assertion)
+
+main :: IO () -- {{{1
+main = defaultMain [
+ test_render_command
+ , test_parse_output
+ , test_response_break_insert
+ , test_response_stopped
+ , test_response_stack_list_frames
+ , test_response_exec_return
+ , test_response_evaluate_expression
+ , test_response_error
+ ]
+
+test_render_command:: Test -- {{{2
+test_render_command = enumTestGroup "render_command" $ map runTest [
+ (
+ MICommand Nothing "break-info" [] []
+ , "-break-info\n"
+ ), (
+ MICommand (Just 23) "exec-arguments" [Option (qp "-v") (Just (qp "word"))] []
+ , "23-exec-arguments \"-v\" \"word\"\n"
+ ), (
+ MICommand (Just 42) "break-commands" [Option (qp "1") Nothing, Option (qp "print v") Nothing] []
+ , "42-break-commands \"1\" \"print v\"\n"
+ )
+ ]
+ where
+ runTest :: (Command, String) -> Assertion
+ runTest (cmd, expected) = expected @=? render_command cmd
+
+test_parse_output :: Test -- {{{2
+test_parse_output = enumTestGroup "parse_output" $ map runTest [
+ -- welcome text {{{3
+ ([paste|
+=thread-group-added,id="i1"
+~"GNU gdb (GDB) 7.2-ubuntu\n"
+~"Copyright (C) 2010 Free Software Foundation, Inc.\n"
+~"License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>\nThis is free software: you are free to change and redistribute it.\nThere is NO WARRANTY, to the extent permitted by law. Type \"show copying\"\nand \"show warranty\" for details.\n"
+~"This GDB was configured as \"x86_64-linux-gnu\".\nFor bug reporting instructions, please see:\n"
+~"<http://www.gnu.org/software/gdb/bugs/>...\n"
+~"Reading symbols from /tmp/tc.elf..."
+~"done.\n"
+(gdb)
+|], Output ([
+ OOBAsyncRecord $ ARNotifyAsyncOutput $ NotifyAsyncOutput Nothing $ AsyncOutput ACThreadGroupAdded [Result "id" (VConst "i1")]
+ ] ++ map (OOBStreamRecord . SRConsoleStreamOutput . ConsoleStreamOutput) [
+ "GNU gdb (GDB) 7.2-ubuntu\n"
+ , "Copyright (C) 2010 Free Software Foundation, Inc.\n"
+ , "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>\nThis is free software: you are free to change and redistribute it.\nThere is NO WARRANTY, to the extent permitted by law. Type \"show copying\"\nand \"show warranty\" for details.\n"
+ , "This GDB was configured as \"x86_64-linux-gnu\".\nFor bug reporting instructions, please see:\n"
+ , "<http://www.gnu.org/software/gdb/bugs/>...\n"
+ , "Reading symbols from /tmp/tc.elf..."
+ , "done.\n"
+ ])
+ Nothing)
+ , -- command result -break-info {{{3
+ ([paste|
+^done,BreakpointTable={nr_rows="0",nr_cols="6",hdr=[{width="7",alignment="-1",col_name="number",colhdr="Num"},{width="14",alignment="-1",col_name="type",colhdr="Type"},{width="4",alignment="-1",col_name="disp",colhdr="Disp"},{width="3",alignment="-1",col_name="enabled",colhdr="Enb"},{width="10",alignment="-1",col_name="addr",colhdr="Address"},{width="40",alignment="2",col_name="what",colhdr="What"}],body=[]}
+(gdb)
+|], Output [] $ Just $ ResultRecord Nothing RCDone [
+ Result "BreakpointTable" $ VTuple $ Tuple [
+ Result "nr_rows" $ VConst "0"
+ , Result "nr_cols" $ VConst "6"
+ , Result "hdr" $ VList $ ValueList [
+ VTuple $ Tuple [
+ Result "width" $ VConst "7"
+ , Result "alignment" $ VConst "-1"
+ , Result "col_name" $ VConst "number"
+ , Result "colhdr" $ VConst "Num"
+ ]
+ , VTuple $ Tuple [
+ Result "width" $ VConst "14"
+ , Result "alignment" $ VConst "-1"
+ , Result "col_name" $ VConst "type"
+ , Result "colhdr" $ VConst "Type"
+ ]
+ , VTuple $ Tuple [
+ Result "width" $ VConst "4"
+ , Result "alignment" $ VConst "-1"
+ , Result "col_name" $ VConst "disp"
+ , Result "colhdr" $ VConst "Disp"
+ ]
+ , VTuple $ Tuple [
+ Result "width" $ VConst "3"
+ , Result "alignment" $ VConst "-1"
+ , Result "col_name" $ VConst "enabled"
+ , Result "colhdr" $ VConst "Enb"
+ ]
+ , VTuple $ Tuple [
+ Result "width" $ VConst "10"
+ , Result "alignment" $ VConst "-1"
+ , Result "col_name" $ VConst "addr"
+ , Result "colhdr" $ VConst "Address"
+ ]
+ , VTuple $ Tuple [
+ Result "width" $ VConst "40"
+ , Result "alignment" $ VConst "2"
+ , Result "col_name" $ VConst "what"
+ , Result "colhdr" $ VConst "What"
+ ]
+ ]
+ , Result "body" $ VList $ EmptyList
+ ]
+ ]
+ )
+ , -- command result break-insert {{{3
+ ([paste|
+^done,bkpt={number="1",type="breakpoint",disp="keep",enabled="y",addr="0x000000000040154e",func="cond_wait",file="tc.c",fullname="/tmp/tc.c",line="23",times="0",original-location="tc.c:23"}
+(gdb)
+|], Output [] $ Just $ ResultRecord Nothing RCDone [
+ Result "bkpt" $ VTuple $ Tuple [
+ Result "number" $ VConst "1"
+ , Result "type" $ VConst "breakpoint"
+ , Result "disp" $ VConst "keep"
+ , Result "enabled" $ VConst "y"
+ , Result "addr" $ VConst "0x000000000040154e"
+ , Result "func" $ VConst "cond_wait"
+ , Result "file" $ VConst "tc.c"
+ , Result "fullname" $ VConst "/tmp/tc.c"
+ , Result "line" $ VConst "23"
+ , Result "times" $ VConst "0"
+ , Result "original-location" $ VConst "tc.c:23"
+ ]
+ ]
+ )
+ , -- command result gdb-version {{{3
+ ([paste|
+~"GNU gdb (GDB) 7.2-ubuntu\n"
+0^done
+(gdb)
+|], Output [OOBStreamRecord $ SRConsoleStreamOutput $ ConsoleStreamOutput "GNU gdb (GDB) 7.2-ubuntu\n"] (Just $ ResultRecord (Just 0) RCDone [])
+ )
+ , -- command result exec-run {{{3
+ ([paste|
+=thread-group-started,id="i1",pid="18510"
+=thread-created,id="1",group-id="i1"
+2^running
+*running,thread-id="all"
+(gdb)
+|], Output [
+ OOBAsyncRecord $ ARNotifyAsyncOutput $ NotifyAsyncOutput Nothing $ AsyncOutput ACThreadGroupStarted [Result "id" (VConst "i1"), Result "pid" (VConst "18510")]
+ , OOBAsyncRecord $ ARNotifyAsyncOutput $ NotifyAsyncOutput Nothing $ AsyncOutput ACThreadCreated [Result "id" (VConst "1"), Result "group-id" (VConst "i1")]
+ , OOBAsyncRecord $ ARExecAsyncOutput $ ExecAsyncOutput Nothing $ AsyncOutput ACRunning [Result "thread-id" (VConst "all")]
+ ] $ Just $ ResultRecord (Just 2) RCRunning []
+ )
+ , -- breakpoint hit {{{3
+ ([paste|
+=library-loaded,id="/lib64/ld-linux-x86-64.so.2",target-name="/lib64/ld-linux-x86-64.so.2",host-name="/lib64/ld-linux-x86-64.so.2",symbols-loaded="0",thread-group="i1"
+=library-loaded,id="/lib/libc.so.6",target-name="/lib/libc.so.6",host-name="/lib/libc.so.6",symbols-loaded="0",thread-group="i1"
+*stopped,reason="breakpoint-hit",disp="keep",bkptno="1",frame={addr="0x0000000000400ba9",func="ec_thread_0",args=[{name="ec_cont",value="0x0"}],file="ec.c",fullname="/tmp/ec.c",line="303"},thread-id="1",stopped-threads="all",core="0"
+(gdb)
+|], Output
+ [
+ OOBAsyncRecord $ ARNotifyAsyncOutput $ NotifyAsyncOutput Nothing $ AsyncOutput ACLibraryLoaded
+ [
+ Result "id" (VConst "/lib64/ld-linux-x86-64.so.2")
+ , Result "target-name" (VConst "/lib64/ld-linux-x86-64.so.2")
+ , Result "host-name" (VConst "/lib64/ld-linux-x86-64.so.2")
+ , Result "symbols-loaded" (VConst "0")
+ , Result "thread-group" (VConst "i1")
+ ]
+ , OOBAsyncRecord $ ARNotifyAsyncOutput $ NotifyAsyncOutput Nothing $ AsyncOutput ACLibraryLoaded
+ [
+ Result "id" (VConst "/lib/libc.so.6")
+ , Result "target-name" (VConst "/lib/libc.so.6")
+ , Result "host-name" (VConst "/lib/libc.so.6")
+ , Result "symbols-loaded" (VConst "0")
+ , Result "thread-group" (VConst "i1")
+ ]
+ , OOBAsyncRecord $ ARExecAsyncOutput $ ExecAsyncOutput Nothing $ AsyncOutput ACStop
+ [
+ Result "reason" (VConst "breakpoint-hit")
+ , Result "disp" (VConst "keep")
+ , Result "bkptno" (VConst "1")
+ , Result "frame" (VTuple $ Tuple
+ [
+ Result "addr" (VConst "0x0000000000400ba9")
+ , Result "func" (VConst "ec_thread_0")
+ , Result "args" (VList $ ValueList [VTuple $ Tuple
+ [
+ Result "name" (VConst "ec_cont")
+ , Result "value" (VConst "0x0")
+ ]])
+ , Result "file" (VConst "ec.c")
+ , Result "fullname" (VConst "/tmp/ec.c")
+ , Result "line" (VConst "303")
+ ])
+ , Result "thread-id" (VConst "1")
+ , Result "stopped-threads" (VConst "all")
+ , Result "core" (VConst "0")
+ ]
+ ] Nothing)
+ ]
+ where
+ runTest :: (String, Output) -> Assertion -- {{{3
+ runTest (str, output) =
+ show output @=? show (parse_output (tail str))
+
+test_response_break_insert :: Test -- {{{2
+test_response_break_insert = enumTestGroup "response_break_insert" $ map runTest [
+ -- example {{{3
+ ([paste|
+^done,bkpt={number="1",type="breakpoint",disp="keep",enabled="y",addr="0x0000000000400ba9",func="ec_thread_0",file="ec.c",fullname="/tmp/ec.c",line="303",times="0",original-location="ec.c:ec_thread_0"}
+(gdb)
+|], Breakpoint 1 "breakpoint" BreakpointKeep True "0x0000000000400ba9" "ec_thread_0" "ec.c" "/tmp/ec.c" 303 0 "ec.c:ec_thread_0")
+ ]
+ where
+ runTest :: (String, Breakpoint) -> Assertion -- {{{3
+ runTest (str, bp) =
+ let
+ output = parse_output (tail str)
+ bp' = do
+ response <- output_response output
+ response_break_insert (respResults response)
+ in
+ show (Just bp) @=? show bp'
+
+test_response_stopped :: Test -- {{{2
+test_response_stopped = enumTestGroup "response_stopped" $ map runTest [
+ -- breakpoint hit {{{3
+ ([paste|
+*stopped,reason="breakpoint-hit",disp="keep",bkptno="7",frame={addr="0x0000000000400e24",func="ec_thread_1",args=[{name="ec_cont",value="0x400ed5"}],file="ec.c",fullname="/tmp/ec.c",line="433"},thread-id="1",stopped-threads="all",core="1"
+(gdb)
+|], Stopped (BreakpointHit BreakpointKeep 7) (Frame Nothing "0x0000000000400e24" "ec_thread_1" (Just [Arg "ec_cont" "0x400ed5"]) "ec.c" (Just "/tmp/ec.c") 433) 1 "all" 1)
+ , -- end stepping range {{{3
+ ([paste|
+*stopped,reason="end-stepping-range",frame={addr="0x00000000004017fa",func="main",args=[],file="pal.c",fullname="/tmp/pal.c",line="196"},thread-id="1",stopped-threads="all",core="1"
+(gdb)
+|], Stopped EndSteppingRange (Frame Nothing "0x00000000004017fa" "main" (Just []) "pal.c" (Just "/tmp/pal.c") 196) 1 "all" 1)
+ ]
+ where
+ runTest :: (String, Stopped) -> Assertion -- {{{3
+ runTest (str, stp) =
+ let
+ output = parse_output (tail str)
+ [notification] = output_notification output
+ stp' = response_stopped (notiResults notification)
+ in
+ show (Just stp) @=? show stp'
+
+test_response_stack_list_frames :: Test -- {{{2
+test_response_stack_list_frames = enumTestGroup "response_stack_list_frames" $ map runTest [
+ -- example {{{3
+ ([paste|
+^done,stack=[frame={level="0",addr="0x00007ffff7a9dcc7",func="_IO_vfprintf_internal",file="vfprintf.c",line="1647"},frame={level="1",addr="0x00007ffff7ac2c79",func="__IO_vsprintf",file="iovsprintf.c",line="43"},frame={level="2",addr="0x0000000000402520",func="logger_syscall",file="logger.c",fullname="/tmp/logger.c",line="57"},frame={level="3",addr="0x0000000000401c13",func="os_receive",file="core.c",fullname="/tmp/core.c",line="145"},frame={level="4",addr="0x0000000000401489",func="tc_receive",file="pal.c",fullname="/tmp/pal.c",line="116"},frame={level="5",addr="0x0000000000400e2e",func="ec_thread_1",file="ec.c",fullname="/tmp/ec.c",line="433"},frame={level="6",addr="0x00000000004016b2",func="flash_write_cb",file="pal.c",fullname="/tmp/pal.c",line="156"},frame={level="7",addr="0x00000000004019ff",func="cb_default",file="core.c",fullname="/tmp/core.c",line="90"},frame={level="8",addr="0x0000000000402f05",func="dispatcher_run",file="dispatcher.c",fullname="/tmp/dispatcher.c",line="93"},frame={level="9",addr="0x000000000040188e",func="os_run",file="core.c",fullname="/tmp/core.c",line="37"},frame={level="10",addr="0x00000000004012f0",func="pal_run",file="pal.c",fullname="/tmp/pal.c",line="70"},frame={level="11",addr="0x0000000000401818",func="main",file="pal.c",fullname="/tmp/pal.c",line="200"}]
+(gdb)
+|], Stack [
+ Frame (Just 0) "0x00007ffff7a9dcc7" "_IO_vfprintf_internal" Nothing "vfprintf.c" Nothing 1647
+ , Frame (Just 1) "0x00007ffff7ac2c79" "__IO_vsprintf" Nothing "iovsprintf.c" Nothing 43
+ , Frame (Just 2) "0x0000000000402520" "logger_syscall" Nothing "logger.c" (Just "/tmp/logger.c") 57
+ , Frame (Just 3) "0x0000000000401c13" "os_receive" Nothing "core.c" (Just "/tmp/core.c") 145
+ , Frame (Just 4) "0x0000000000401489" "tc_receive" Nothing "pal.c" (Just "/tmp/pal.c") 116
+ , Frame (Just 5) "0x0000000000400e2e" "ec_thread_1" Nothing "ec.c" (Just "/tmp/ec.c") 433
+ , Frame (Just 6) "0x00000000004016b2" "flash_write_cb" Nothing "pal.c" (Just "/tmp/pal.c") 156
+ , Frame (Just 7) "0x00000000004019ff" "cb_default" Nothing "core.c" (Just "/tmp/core.c") 90
+ , Frame (Just 8) "0x0000000000402f05" "dispatcher_run" Nothing "dispatcher.c" (Just "/tmp/dispatcher.c") 93
+ , Frame (Just 9) "0x000000000040188e" "os_run" Nothing "core.c" (Just "/tmp/core.c") 37
+ , Frame (Just 10) "0x00000000004012f0" "pal_run" Nothing "pal.c" (Just "/tmp/pal.c") 70
+ , Frame (Just 11) "0x0000000000401818" "main" Nothing "pal.c" (Just "/tmp/pal.c") 200
+ ])
+ ]
+ where
+ runTest :: (String, Stack) -> Assertion -- {{{3
+ runTest (str, stack) =
+ let
+ output = parse_output (tail str)
+ stack' = do
+ response <- output_response output
+ response_stack_list_frames (respResults response)
+ in
+ show (Just stack) @=? show stack'
+
+test_response_exec_return :: Test -- {{{2
+test_response_exec_return = enumTestGroup "response_exec_return" $ map runTest [
+ -- example {{{3
+ ([paste|
+^done,frame={level="0",addr="0x080483cc",func="f",args=[],file="foo.c",fullname="/tmp/foo.c",line="9"}
+(gdb)
+|], Frame (Just 0) "0x080483cc" "f" (Just []) "foo.c" (Just "/tmp/foo.c") 9
+ )
+ ]
+ where
+ runTest :: (String, Frame) -> Assertion -- {{{3
+ runTest (str, frame) =
+ let
+ output = parse_output (tail str)
+ frame' = do
+ response <- output_response output
+ response_exec_return (respResults response)
+ in
+ show (Just frame) @=? show frame'
+
+test_response_evaluate_expression :: Test -- {{{2
+test_response_evaluate_expression = enumTestGroup "response_evaluate_expression" $ map runTest [
+ -- example {{{3
+ ([paste|
+^done,value="24"
+(gdb)
+|], "24")
+ ]
+ where
+ runTest :: (String, String) -> Assertion -- {{{3
+ runTest (str, expr) =
+ let
+ output = parse_output (tail str)
+ (Just response) = output_response output
+ in do
+ RCDone @=? respClass response
+ Just expr @=? (response_data_evaluate_expression . respResults) response
+
+test_response_error :: Test -- {{{2
+test_response_error = enumTestGroup "response_error" $ map runTest [
+ -- example {{{3
+ ([paste|
+^error,msg="No symbol \"j\" in current context."
+(gdb)
+|], "No symbol \"j\" in current context.")
+ ]
+ where
+ runTest :: (String, String) -> Assertion -- {{{3
+ runTest (str, err) =
+ let
+ output = parse_output (tail str)
+ (Just response) = output_response output
+ in do
+ RCError @=? respClass response
+ Just err @=? (response_error . respResults) response
+
+-- utils {{{1
+qp :: String -> Parameter
+qp = QuotedString
Please sign in to comment.
Something went wrong with that request. Please try again.