diff --git a/GDBMI.hs b/GDBMI.hs deleted file mode 100644 --- a/GDBMI.hs +++ /dev/null @@ -1,198 +0,0 @@ --- hgdbmi: a Haskell interface to GDB/MI. --- Copyright (C) 2008 Evan Martin - --- |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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright (c) 2008 Evan Martin +Copyright (c) 2012 Alexander Bernauer All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Test.hs b/Test.hs deleted file mode 100644 --- a/Test.hs +++ /dev/null @@ -1,89 +0,0 @@ --- hgdbmi: a Haskell interface to GDB/MI. --- Copyright (C) 2008 Evan Martin - -import GDBMI -import Test.HUnit - -startupText = - "~\"GNU gdb 6.7.1-debian\\n\"\n" ++ - "~\"Copyright (C) 2007 Free Software Foundation, Inc.\\n\"\n" ++ - "~\"License GPLv3+: GNU GPL version 3 or later \\n\"\n" ++ - "~\"This is free software: you are free to change and redistribute it.\\n\"\n" ++ - "~\"There is NO WARRANTY, to the extent permitted by law. Type \\\"show copying\\\"\\n\"\n" ++ - "~\"and \\\"show warranty\\\" for details.\\n\"\n" ++ - "~\"This GDB was configured as \\\"i486-linux-gnu\\\".\\n\"\n" ++ - "~\"Attaching to process 8902\\n\"\n" ++ - "~\"Reading symbols from /home/martine/projects/c-repl/dist/build/child...\"\n" ++ - "~\"done.\\n\"\n" ++ - "~\"Using host libthread_db library \\\"/lib/tls/i686/cmov/libthread_db.so.1\\\".\\n\"\n" ++ - "~\"Reading symbols from /lib/tls/i686/cmov/libdl.so.2...\"\n" ++ - "~\"done.\\n\"\n" ++ - "~\"Loaded symbols for /lib/tls/i686/cmov/libdl.so.2\\n\"\n" ++ - "~\"Reading symbols from /lib/tls/i686/cmov/libc.so.6...\"\n" ++ - "~\"done.\\n\"\n" ++ - "~\"Loaded symbols for /lib/tls/i686/cmov/libc.so.6\\n\"\n" ++ - "~\"Reading symbols from /lib/ld-linux.so.2...\"\n" ++ - "~\"done.\\n\"\n" ++ - "~\"Loaded symbols for /lib/ld-linux.so.2\\n\"\n" ++ - "~\"Reading symbols from /home/martine/projects/c-repl/.c-repl/dl1.so...\"\n" ++ - "~\"done.\\n\"\n" ++ - "~\"Loaded symbols for ./.c-repl/dl1.so\\n\"\n" - -testStartup = test $ - case GDBMI.parse "startup" startupText of - Left err -> assertFailure $ show err - Right (MIOutput info result) -> do - assertEqual "oob line count" 23 (length info) - assertEqual "oob first line" - (MIConsole "GNU gdb 6.7.1-debian\n") (head info) - -printText = - "&\"p x\\n\"\n" ++ - "~\"$1 = 3\"\n" ++ - "~\"\n\"\n" ++ - "^done,thread-id=\"0\",frame={addr=\"0xb7f0a410\",func=\"__kernel_vsyscall\",args=[]}\n" - -testPrint = test $ - case GDBMI.parse "parse 'p x' output" printText of - Left err -> assertFailure $ show err - Right (MIOutput info result) -> do - assertEqual "oob line count" 3 (length info) - assertEqual "oob first line" (MILog "p x\n") (head info) - case result of - Just (MIDone tuples) -> do - assertEqual "done tuple #1" ("thread-id", MIString "0") (head tuples) - case lookup "frame" tuples of - Just (MITuple frame) -> - assertEqual "done tuple #4" ("args", MITuple []) (last frame) - _ -> assertFailure $ "couldn't find 'frame'" - _ -> - assertFailure $ "expected done result, got " ++ show result - -errorPrintText = - "&\"p y\\n\"\n" ++ - "&\"No symbol \\\"y\\\" in current context.\\n\"\n" ++ - "^error,msg=\"No symbol \\\"y\\\" in current context.\"\n" - -testErrorPrint = test $ - case GDBMI.parse "parse 'p y' error output" errorPrintText of - Left err -> assertFailure $ show err - Right (MIOutput info result) -> do - assertEqual "oob line count" 2 (length info) - assertEqual "oob first line" (MILog "p y\n") (head info) - assertEqual "result" - (Just (MIError "No symbol \"y\" in current context.")) result - -varCreateText = "^done,name=\"vx\",numchild=\"0\",value=\"4\",type=\"int\"\n" - -testVarCreate = test $ - case GDBMI.parse "parse 'var-create' output" varCreateText of - Left err -> assertFailure $ show err - Right (MIOutput info result) -> do - assertEqual "no oob info" 0 (length info) - assertEqual "result" - (Just (MIDone [("name", MIString "vx"), ("numchild", MIString "0"), - ("value", MIString "4"), ("type", MIString "int")])) - result - -main = - runTestTT $ TestList [testStartup, testPrint, testErrorPrint, testVarCreate] diff --git a/hgdbmi.cabal b/hgdbmi.cabal --- a/hgdbmi.cabal +++ b/hgdbmi.cabal @@ -1,21 +1,84 @@ -Cabal-Version: >= 1.2 -Build-Type: Simple -Name: hgdbmi -Version: 0.1 -Synopsis: GDBMI interface (program-driven control of GDB) +name: hgdbmi +category: Development +version: 0.2 +license: BSD3 +cabal-version: >= 1.14 +license-file: LICENSE +author: Alexander Bernauer, Evan Martin +maintainer: Alexander Bernauer +stability: provisional +homepage: https://github.com/copton/hgdbmi +bug-reports: https://github.com/copton/hgdbmi/issues +copyright: (c) 2012 Alexander Bernauer , 2008 Evan Martin +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 wraps attaching GDB to a process and parsing the - (surprisingly complicated) GDB\/MI output. -Category: Development -License: BSD3 -License-File: LICENSE -Author: Evan Martin -Maintainer: martine@danga.com -Copyright: (c) 2008 Evan Martin -Homepage: http://neugierig.org/software/darcs/browse/?r=hgdbmi;a=summary -Extra-Source-Files: Test.hs + GDB\/MI lets programs drive GDB. It can be used, for example, by GDB + 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 is tested with GDB version 7.4. -Library - Build-Depends: base, parsec, process, unix - Exposed-Modules: GDBMI +build-type: Simple +tested-with: GHC == 7.4.2 + +source-repository head + type: git + location: git://github.com/copton/hgdbmi.git + +source-repository this + type: git + location: git://github.com/copton/hgdbmi.git + tag: v0.2 + +library + build-depends: + base >= 4 && < 5, + parsec == 3.1.*, + process == 1.1.*, + unix == 2.6.*, + stm == 2.3.* + + exposed-modules: + Gdbmi.IO + Gdbmi.Commands + Gdbmi.Representation + Gdbmi.Semantics + + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 + +test-suite pure + type: exitcode-stdio-1.0 + main-is: pure.hs + other-modules: Paste + hs-source-dirs: tests + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + hgdbmi, + base >= 4 && < 5, + HUnit == 1.2.*, + test-framework == 0.6.*, + test-framework-hunit == 0.2.*, + template-haskell + + +test-suite io + type: exitcode-stdio-1.0 + main-is: io.hs + other-modules: Paste + hs-source-dirs: tests + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + hgdbmi, + base >= 4 && < 5, + directory == 1.2.*, + process == 1.1.*, + temporary == 1.1.*, + template-haskell diff --git a/src/Gdbmi/Commands.hs b/src/Gdbmi/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Gdbmi/Commands.hs @@ -0,0 +1,828 @@ +-- | Constructor functions for 'Gdmi.Representation.Command' values. +-- +-- Please consult the cited GDB documentation for the semantics of the individual commands. +module Gdbmi.Commands +-- {{{1 exports +( + -- * Commands + -- ** Breakpoint Commands + -- | + break_after, + break_commands, + break_condition, + break_delete, + break_disable, + break_enable, + break_info, + break_insert, + break_list, + break_passcount, + break_watch, + + -- ** Program Context + -- | + exec_arguments, + environment_cd, + environment_directory, + environment_path, + environment_pwd, + + -- ** Thread Commands + -- | + thread_info, + thread_list_ids, + thread_select, + + -- ** Ada Tasking Commands + -- | + ada_task_info, + + -- ** Program Execution + -- | + exec_continue, + exec_finish, + exec_interrupt, + exec_jump, + exec_next, + exec_next_instruction, + exec_return, + exec_run, + exec_step, + exec_step_instruction, + exec_until, + + -- ** Stack Manipulation + -- | + stack_info_frame, + stack_info_depth, + stack_list_arguments, + stack_list_arguments', + stack_list_frames, + stack_list_locals, + stack_list_locals', + stack_list_variables, + stack_list_variables', + stack_select_frame, + + -- ** Variable Objects + -- | + enable_pretty_printing, + var_create, + var_delete, + var_set_format, + var_gdbShow_format, + var_info_num_children, + var_list_children, + var_list_children', + var_info_type, + var_info_expression, + var_info_path_expressoin, + var_gdbShow_attributes, + var_evaluate_expression, + var_assign, + var_update, + var_set_frozen, + var_set_update_range, + var_set_visualizer, + + -- ** Data Manipulation + -- | + data_disassemble, + data_evaluate_expression, + data_list_changed_registers, + data_list_register_names, + data_list_register_values, + data_read_memory, + data_read_memory_bytes, + data_write_memory_bytes, + + -- ** Tracepoint Commands + -- | + trace_find, + trace_define_variable, + trace_list_variables, + trace_save, + trace_start, + trace_status, + trace_stop, + + -- ** Symbol Query + -- | + symbol_list_lines, + + -- ** File Commands + -- | + file_exec_and_symbols, + file_exec_file, + file_list_exec_source_file, + file_list_exec_source_files, + file_symbol_file, + + -- ** Target Manipulation + -- | + target_attach, + target_detach, + target_disconnect, + target_download, + target_select, + + -- ** File Transfer Commands + -- | + target_file_put, + target_file_get, + target_file_delete, + + -- ** Miscellaneous Commmands + -- | + gdb_exit, + gdb_set, + gdb_gdbShow, + gdb_version, + list_features, + list_target_features, + list_thread_groups, + info_os, + add_inferior, + interpreter_exec, + inferior_tty_set, + inferior_tty_gdbShow, + enable_timings, + + -- * Auxiliary Types + -- ** Location + -- | . + Location, + positive_offset_location, + negative_offset_location, + file_line_location, + function_location, + function_label_location, + file_function_location, + label_location, + plain_address_location, + expr_address_location, + func_address_location, + file_func_address_location, + + -- ** Other Types + -- | See the documentation of the commands that use these types for their semantics. + PrintValues(..), + FrameSelect(..), + FormatSpec(..), + FrozenFlag(..), + DisassemblyMode(..), + DataFormat(..), + OutputFormat(..), + TraceMode(..), + Target(..), + Medium(..), + Interpreter(..), + + -- * Helper Functions + cli_command, + set_token +) where + +-- imports {{{1 +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Prelude hiding (reverse, all, lines) + +import Gdbmi.Representation (Command(..), Option(..), Token, Parameter(..), render_command) + +-- 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 + +newtype Location = Location String -- {{{2 + +instance GdbShow Location where -- {{{3 + gdbShow (Location location) = location + +positive_offset_location :: Int -> Location -- {{{3 +positive_offset_location offset = Location $ "+" ++ gdbShow offset + +negative_offset_location :: Int -> Location -- {{{3 +negative_offset_location offset = Location $ "-" ++ gdbShow offset + +file_line_location :: String -> Int -> Location -- {{{3 +file_line_location filename linenum = Location $ filename ++ ":" ++ gdbShow linenum + +function_location :: String -> Location -- {{{3 +function_location = Location + +function_label_location :: String -> String -> Location -- {{{3 +function_label_location function label = Location $ function ++ ":" ++ label + +file_function_location :: String -> String -> Location -- {{{3 +file_function_location filename function = Location $ filename ++ ":" ++ function + +label_location :: String -> Location -- {{{3 +label_location = Location + +plain_address_location :: String -> Location -- {{{3 +plain_address_location addr = Location $ "*" ++ addr + +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 = Location $ "'" ++ filename ++ "'::" ++ funcaddr + +data PrintValues -- {{{2 + = NoValues -- ^ \"--no-values\" or \"0\" + | AllValues -- ^ \"--all-values\" or \"1\" + | SimpleValues -- ^ \"--simple-values\" or \"2\" + +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 -- ^ just the given address + | CurrentFrame -- ^ \"*\" + | Floating -- ^ \"\@\" + +instance GdbShow FrameSelect where + gdbShow (FrameAddr addr) = addr + gdbShow CurrentFrame = "*" + gdbShow Floating = "@" + +data FormatSpec -- {{{2 + = Binary -- ^ \"binary\" + | Decimal -- ^ \"decimal\" + | Hexadecimal -- ^ \"hexadecimal\" + | Octal -- ^ \"octal\" + | Natural -- ^ \"natural\" + +instance GdbShow FormatSpec where + gdbShow Binary = "binary" + gdbShow Decimal = "decimal" + gdbShow Hexadecimal = "hexadecimal" + gdbShow Octal = "octal" + gdbShow Natural = "natural" + +data FrozenFlag -- {{{2 + = Frozen -- ^ \"1\" + | Unfrozen -- ^ \"0\" + +instance GdbShow FrozenFlag where + gdbShow Frozen = "1" + gdbShow Unfrozen = "0" + +data DisassemblyMode -- {{{2 + = DisassemblyMode Bool Bool -- ^ with mixed source?, with 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 -- ^ \"x\" + | DOctal -- ^ \"o\" + | DBinary -- ^ \"t\" + | DDecimal -- ^ \"d\" + | DRaw -- ^ \"r\" + | DNatural -- ^ \"N\" + +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 -- ^ \"x\" + | SignedDecimalInteger -- ^ \"d\" + | UnsignedDecimalInteger -- ^ \"u\" + | OctalInteger -- ^ \"o\" + | BinaryInteger -- ^ \"t\" + | Address -- ^ \"a\" + | CharacterConstantInteger -- ^ \"c\" + | FloatingPointNumber -- ^ \"f\" + | OString -- ^ \"s\" + | Raw -- ^ \"r\" + +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 -- ^ \"none\" + | FrameNumber Int -- ^ \"frame-number\" + | TracepointNumber Int -- ^ \"tracepoint-number\" + | PC String -- ^ \"pc\" + | PCInsideRange String String -- ^ \"pc-inside-range\" + | PCOutsideRange String String -- ^ \"pc-outside-range\" + | Line Location -- ^ \"line\" + +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 -- ^ \"exec\" + | Core FilePath -- ^ \"core\" + | Remote Medium -- ^ \"remote\" + | Sim [String] -- ^ \"sim\" + | Nrom -- ^ \"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 -- ^ just the given device + | TcpHost String Int -- ^ \"tcp:%s:%d\" host port + | UdpHost String Int -- ^ \"udp:%s:%d\" host port + | Pipe String -- ^ \"|%s\" command + +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 -- ^ \"console\" + | MI -- ^ \"mi\" + | MI2 -- ^ \"mi2\" + | MI1 -- ^ \"mi1\" + +instance GdbShow Interpreter where + gdbShow Console = "console" + gdbShow MI = "mi" + gdbShow MI2 = "mi2" + gdbShow MI1 = "mi1" + +-- helper {{{1 +set_token :: Token -> Command -> Command -- {{{2 +-- | Set the token of a command. +-- +-- +-- Newly created commands have no token, but setting a token manually is usually not necessary. +-- 'Gdbmi.IO.send_command' will assign a unique token to a given command in any case. +set_token token (MICommand _ x y z) = MICommand (Just token) x y z +set_token token (CLICommand _ x) = CLICommand (Just token) x + +cli_command :: String -> Command +-- | Create a CLI command, i.e., use the provided string literaly. +-- +-- Some GDB commands are not reflected in the Machine Interface. In those +-- cases one has to resort to Command Line Interface commands, which the MI +-- accepts as well. +cli_command = CLICommand Nothing + +-- 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 {{{2 +ada_task_info :: Maybe Int -> Command -- {{{3 +ada_task_info taskId = cmd "ada-task-info" $ fmap opt taskId ?: [] + +-- 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) diff --git a/src/Gdbmi/IO.hs b/src/Gdbmi/IO.hs new file mode 100644 --- /dev/null +++ b/src/Gdbmi/IO.hs @@ -0,0 +1,239 @@ +-- | Control execution of a GDB instance, send commands and receive results, notifications and stream information. +-- +-- Due to the first command issued should be to set the output terminal for GDB to \/dev\/null. Unfortunatelly, there is no MI command for this, so we have to resort to the CLI command \"tty\". For example: +-- +-- >>> ctx <- setup config callback +-- >>> resp <- send_command ctx (cli_command "tty /dev/null") +-- >>> when (respClass resp /= RCDone) (error ("unexpected response: " ++ show resp)) +-- +module Gdbmi.IO +-- exports {{{1 +( + Context, Config(..), Callback(..) + , default_config + , 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_, when) +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, hClose) +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.Semantics 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 + } + +-- | Call-back functions for asynchronous GDB output. +-- +-- The call-backs are called in a separate thread per GDB output, so they may block. +-- +-- Stop events are 'Gdbmi.Representation.Notification' events with 'R.NotificationClass' 'R.Exec' and 'R.AsyncClass' 'R.ACStop'. +-- If 'cbStopped' is given stop events are delivered to that call-back instead of 'cbNotify'. +data Callback -- {{{1 + = Callback { + cbStream :: [R.Stream] -> IO () -- ^ call-back for 'Gdbmi.Representation.Stream' events + , cbNotify :: [R.Notification] -> IO () -- ^ call-back for 'Gdbmi.Representation.Notification' events + , cbStopped :: Maybe ([S.Stopped] -> IO ()) -- ^ optionally a special call-back for 'Gdbmi.Semantics.Stopped' events + } + +-- | Configuration +data Config -- {{{1 + = Config { + confCommandLine :: [String] -- ^ command line to execute. The library will add \"--interpreter mi\". + , confLogfile :: Maybe FilePath -- ^ optinonally a file path to a log file for GDB\/MI input and output. \'-\' means stdout. + } + +default_config :: Config -- {{{2 +-- | Default configuration: "gdb" command line, no log file +default_config = Config ["gdb"] Nothing + +setup :: Config -> Callback -> IO Context -- {{{1 +-- | Launch a GDB instance in Machine Interface mode. +-- +-- The child process is run in a new session to avoid receiving SIGINTs when issuing -exec-interrupt. +setup config callback = do + (commandR, commandW) <- createPipe >>= asHandles + (outputR, outputW) <- createPipe >>= asHandles + phandle <- runProcess "setsid" (confCommandLine config ++ ["--interpreter", "mi"]) + Nothing Nothing + (Just commandR) + (Just outputW) + Nothing + mapM_ (`hSetBuffering` LineBuffering) [commandW, outputR] + logH <- case (confLogfile config) 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 +-- | Shut down the GDB instance and all resources associated with the 'Context'. +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) () + case ctxLog ctx of + Nothing -> return () + Just handle -> + if handle /= stdout + then hClose handle + else return () + +send_command :: Context -> R.Command -> IO R.Response -- {{{1 +-- | Send a GDB command and wait for the response. +-- +-- This function is thread safe, i.e., it can be called by multiple threads in an interleaved fashion. +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 + _ <- callBack ctx output + 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 + +callBack :: Context -> R.Output -> IO () +callBack ctx output = forkIO go >> return () + where + go = + let + callbacks = ctxCallback ctx + streamsCb = cbStream callbacks + notifyCb = cbNotify callbacks + stoppedCbMb = cbStopped callbacks + + 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.notification_stopped . R.notiResults) stops + in case stoppedCbMb of + Nothing -> do + when (not (null streams)) (streamsCb streams) + when (not (null notifications)) (notifyCb notifications) + Just stoppedCb -> do + when (not (null streams)) (streamsCb streams) + when (not (null others)) (notifyCb others) + when (not (null stops')) (stoppedCb stops') + +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.set_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 diff --git a/src/Gdbmi/Representation.hs b/src/Gdbmi/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Gdbmi/Representation.hs @@ -0,0 +1,506 @@ +-- | Data structures, parsers and printers for GDB/MI communication. +-- +-- This is a low-level module not intended to be used by clients of this library. +-- Use 'Gdbmi.Commands' to create commands and receive responses as well as notifications via 'Gdbmi.IO'. +-- +-- On-the-wire types reflect the GDB/MI grammar. Please consult the cited GDB documentation for details. +-- The simplified types provide a simple abstraction over the on-the-wire types. +module Gdbmi.Representation +-- exports {{{1 +( + -- * On-the-Wire Types + -- ** Input + -- | + Command(..), + Token, + Operation, + Option(..), + Parameter(..), + -- ** Output + -- | + Output(..), + ResultRecord(..), + OutOfBandRecord(..), + AsyncRecord(..), + ExecAsyncOutput(..), + StatusAsyncOutput(..), + NotifyAsyncOutput(..), + AsyncOutput(..), + ResultClass(..), + AsyncClass(..), + Result(..), + Variable, + Value(..), Const, Tuple(..), List(..), + StreamRecord(..), + ConsoleStreamOutput(..), + TargetStreamOutput(..), + LogStreamOutput(..), + CString, + -- * Simplified + Response(..), + Notification(..), NotificationClass(..), + Stream(..), StreamClass(..), + -- * Functions + render_command, + parse_output, + output_response, + output_notification, + output_stream, + GetToken(..), + asConst, asTuple, asList, + parameter_valid +) 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 +-- | Generate the on-the-wire string suitable to be sent to GDB. +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 + = 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 +-- | Turn an GDB output string to an 'Output' value. +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 + -- | The 'ResultRecord' of an 'Output' + = Response { + respClass :: ResultClass + , respResults :: [Result] + } + deriving (Show) + +data Notification -- {{{2 + -- | Simplification of the 'AsyncRecord' type hierarchie, a possible 'OutOfBandRecord' value of an 'Output'. + = Notification { + notiClass :: NotificationClass + , notiAsyncClass :: AsyncClass + , notiResults :: [Result] + } + deriving Show + +data NotificationClass -- {{{3 + = Exec -- ^ 'ARExecAsyncOutput' + | Status -- ^ 'ARStatusAsyncOutput' + | Notify -- ^ 'ARNotifyAsyncOutput' + deriving (Show, Eq) + +data Stream -- {{{2 + -- | Simplifcation of the 'StreamRecord' type hierarchie, a possible 'OutOfBandRecord' value of an 'Output'. + = Stream StreamClass String + deriving Show + +data StreamClass -- {{{3 + = Console -- ^ 'SRConsoleStreamOutput' + | Target -- ^ 'SRTargetStreamOutpu' + | Log -- ^ 'SRLogStreamOutput' + deriving Show + +output_response :: Output -> Maybe Response -- {{{2 +-- | Extract the response from an output, if existent. +output_response (Output _ Nothing) = Nothing +output_response (Output _ (Just (ResultRecord _ rc rs))) = Just $ Response rc rs + +output_notification :: Output -> [Notification] -- {{{2 +-- | Extract the (possible empty) list of notifications of an output. +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 +-- | Extract the (possibly) empty list of notifications of an output. +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 +-- | Coerce a value to a const. +asConst (VConst x) = Just x +asConst _ = Nothing + +asTuple :: Value -> Maybe Tuple -- {{{2 +-- | Coerce a value to a tuple. +asTuple (VTuple x) = Just x +asTuple _ = Nothing + +asList :: Value -> Maybe List -- {{{2 +-- | Coerce a value to a list. +asList (VList x) = Just x +asList _ = Nothing + +-- token {{{1 +type Token = Int + +-- | Return the token of the given object, if existent. +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 +-- | Verify that the given parameter is either a c-string or a \"non-blank-sequence\". +-- See +parameter_valid (RawString s) = validParam s +parameter_valid (QuotedString s) = validParam s + +validParam :: String -> Bool -- {{{2 +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 diff --git a/src/Gdbmi/Semantics.hs b/src/Gdbmi/Semantics.hs new file mode 100644 --- /dev/null +++ b/src/Gdbmi/Semantics.hs @@ -0,0 +1,222 @@ +-- | Semantical data structures and conversion functions for GDB\/MI output. +-- +-- While working with 'Gdbmi.Representation.Response' and 'Gdbmi.Representation.Notification' is always possible in general, handling the generic 'Gdbmi.Representation.Result' lists is cumbersome. This module provides convenient data types instead to facilitate pattern matching etc.. +-- +-- This module is incomplete, as we only implemented what we needed up to now. +module Gdbmi.Semantics +-- export {{{1 +( + -- * Conversion Functions + -- | A conversion fails if the result list does not contain the expected values. + response_break_insert, + response_data_evaluate_expression, + response_exec_return, + response_stack_list_frames, + response_error, + notification_stopped, + -- * Types + -- | Please consult the GDB manual for details on the returned responses. + Breakpoint(..), BreakpointType, BreakpointDisp(..), BkptNumber, + Stack(..), Frame(..), Arg(..), + Stopped(..), StopReason(..) +) 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" + +-- functions {{{1 +response_stack_list_frames :: [Result] -> Maybe Stack -- {{{2 +-- | Convert the result list of a 'Gdbmi.Commands.stack_list_frames' command response. +response_stack_list_frames [item] = responseStack item +response_stack_list_frames _ = Nothing + +response_break_insert :: [Result] -> Maybe Breakpoint -- {{{2 +-- | Convert the result list of a 'Gdbmi.Commands.break_insert' command response. +response_break_insert [item] = responseBreakpoint item +response_break_insert _ = Nothing + +response_data_evaluate_expression :: [Result] -> Maybe String -- {{{2 +-- | Convert the result list of a 'Gdbmi.Commands.data_evaluate_expression' command response. +response_data_evaluate_expression [(Result variable value)] = do + guard (variable == "value") + asConst value +response_data_evaluate_expression _ = Nothing + +response_exec_return :: [Result] -> Maybe Frame -- {{{2 +-- | Convert the result list of a 'Gdbmi.Commands.exec_return' command response. +response_exec_return [item] = responseFrame item +response_exec_return _ = Nothing + +response_error :: [Result] -> Maybe String -- {{{2 +-- | Convert the result list of a 'Gdbmi.Representation.Response' with 'Gdbmi.Representation.ResultClass' 'Gdbmi.Representation.RCError'. +response_error [(Result variable value)] = do + guard (variable == "msg") + asConst value +response_error _ = Nothing + +notification_stopped :: [Result] -> Maybe Stopped -- {{{2 +-- | Convert the result list of a 'Gdbmi.Representation.Notification' with 'Gdbmi.Representation.NotificationClass' 'Gdbmi.Representation.Exec' and 'Gdbmi.Representation.AsyncClass' 'Gdbmi.Representation.ACStop'. +notification_stopped items = responseStopped items + +-- 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 diff --git a/tests/Paste.hs b/tests/Paste.hs new file mode 100644 --- /dev/null +++ b/tests/Paste.hs @@ -0,0 +1,12 @@ +module Paste where + +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH (stringE) + +paste :: QuasiQuoter +paste = QuasiQuoter { + quoteExp = stringE, + quotePat = undefined, + quoteType = undefined, + quoteDec = undefined + } diff --git a/tests/io.hs b/tests/io.hs new file mode 100644 --- /dev/null +++ b/tests/io.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE QuasiQuotes #-} +{- + - Test the IO interface of hgdbmi. + - + - Requirements: + - - gdb (see config) + - - gcc (see setup) + - + - Steps: + - - create temporary directory + - - write test program (example) + - - compile test program with debugging + - - start debugger + - - set breakpoint + - - run debugger + - - wait for stop event, evaluate variable and continue (10 times) + - - quit + - - dump log file + - + - Output: + - - stream and notification events (excluding stop events) + - - log file with GDB/MI communication +-} +module Main (main) where + +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, MVar) +import Control.Exception.Base (bracket) +import Control.Monad (forM_, when) +import System.Directory (removeDirectoryRecursive, getCurrentDirectory, setCurrentDirectory) +import System.Exit (ExitCode(..)) +import System.IO.Temp (createTempDirectory) +import System.Process (readProcessWithExitCode) +import Text.Printf (printf) + +import Paste (paste) + +import qualified Gdbmi.IO as G +import qualified Gdbmi.Commands as C +import qualified Gdbmi.Semantics as S +import qualified Gdbmi.Representation as R + +config :: G.Config +config = G.Config ["gdb"] (Just "gdb.log") + +example :: String +example = [paste| +#include + +void print(int i) { + printf("hello world %d\n", i); +} + +int main() { + int i; + for (i=0; ; i++) { + print(i); + } + return 0; +} +|] + +callback :: MVar [S.Stopped] -> G.Callback +callback mv = G.Callback print print (Just (putMVar mv)) + +setup :: IO () +setup = do + writeFile "example.c" example + (ec, sout, serr) <- readProcessWithExitCode "gcc" (words "-o example -g example.c") "" + case ec of + ExitFailure ec' -> do + putStrLn sout + putStrLn serr + error $ printf "failed to execute gcc: %s" (show ec') + ExitSuccess -> return () + +command :: G.Context -> R.ResultClass -> R.Command -> IO [R.Result] +command ctx rc cmd = do + resp <- G.send_command ctx cmd + let msg = printf "command '%s' failed (%s): %s" + (R.render_command cmd) + (show (R.respClass resp)) + ((show . S.response_error . R.respResults) resp) + when (R.respClass resp /= rc) (error msg) + return (R.respResults resp) + +assert :: (Eq a, Show a) => String -> a -> a -> IO () +assert what x y = if (x == y) + then return () + else error $ printf "assertion failed: %s: %s vs. %s" what (show x) (show y) + +test :: IO () +test = do + _ <- setup + mv <- newEmptyMVar + ctx <- G.setup config (callback mv) + let cmd = command ctx + _ <- cmd R.RCDone $ C.cli_command "tty /dev/null" + _ <- cmd R.RCDone $ C.file_exec_and_symbols (Just "example") + let loc = C.file_function_location "example.c" "print" + bp' <- cmd R.RCDone $ C.break_insert False False False False False Nothing Nothing Nothing loc + let (Just bp) = S.response_break_insert bp' + _ <- cmd R.RCRunning $ C.exec_run (Left True) + forM_ [(0::Int)..10] (\counter -> do + [stopped] <- takeMVar mv + assert "breakpoint number" ((S.bkptHitNumber . S.stoppedReason) stopped) (S.bkptNumber bp) + value' <- cmd R.RCDone $ C.data_evaluate_expression "i" + let (Just value) = S.response_data_evaluate_expression value' + assert "value of i" value (show counter) + _ <- cmd R.RCRunning $ C.exec_continue False (Left True) + return () + ) + G.shutdown ctx + readFile "gdb.log" >>= putStr + +withTemporaryDirectory :: IO a -> IO a +withTemporaryDirectory f = bracket acquire release inbetween + where + acquire = do + tmpdir <- createTempDirectory "/tmp" "hgdbmi-test" + curdir <- getCurrentDirectory + setCurrentDirectory tmpdir + return (curdir, tmpdir) + + release (curdir, tmpdir) = do + setCurrentDirectory curdir + removeDirectoryRecursive tmpdir + + inbetween (_, _) = f + +main :: IO () +main = withTemporaryDirectory test diff --git a/tests/pure.hs b/tests/pure.hs new file mode 100644 --- /dev/null +++ b/tests/pure.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main (main) where + +-- imports {{{1 +import Gdbmi.Representation +import Gdbmi.Semantics +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), Assertion) +import Text.Printf (printf) + +import Paste (paste) + +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_data_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 \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" +~"...\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 \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" + , "...\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' = notification_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_data_evaluate_expression :: Test -- {{{2 +test_response_data_evaluate_expression = enumTestGroup "response_data_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 + +enumTestGroup :: String -> [Assertion] -> Test +enumTestGroup name = + testGroup name . zipWith (testCase . printf "%.2d") [(1 :: Int)..]