hgdbmi 0.1 → 0.2

raw patch · 11 files changed

+2368/−306 lines, 11 filesdep +HUnitdep +directorydep +hgdbmidep ~basedep ~parsecdep ~processnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, directory, hgdbmi, stm, template-haskell, temporary, test-framework, test-framework-hunit

Dependency ranges changed: base, parsec, process, unix

API changes (from Hackage documentation)

Files

• GDBMI.hs +0/−198
• LICENSE +1/−0
• Test.hs +0/−89
• hgdbmi.cabal +82/−19
• src/Gdbmi/Commands.hs +828/−0
• src/Gdbmi/IO.hs +239/−0
• src/Gdbmi/Representation.hs +506/−0
• src/Gdbmi/Semantics.hs +222/−0
• tests/Paste.hs +12/−0
• tests/io.hs +131/−0
• tests/pure.hs +347/−0

@@ -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

@@ -1,4 +1,5 @@ Copyright (c) 2008 Evan Martin <martine@danga.com>+Copyright (c) 2012 Alexander Bernauer <acopton@gmail.com> All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,89 +0,0 @@--- hgdbmi: a Haskell interface to GDB/MI.--- Copyright (C) 2008 Evan Martin <martine@danga.com>--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 <http://gnu.org/licenses/gpl.html>\\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]

@@ -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 <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>, 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 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 <martine@danga.com>-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 

@@ -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+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Breakpoint-Commands.html>+  break_after,+  break_commands,+  break_condition,+  break_delete,+  break_disable,+  break_enable,+  break_info,+  break_insert,+  break_list,+  break_passcount,+  break_watch,++  -- ** Program Context+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Program-Context.html>+  exec_arguments,+  environment_cd,+  environment_directory,+  environment_path,+  environment_pwd,++  -- ** Thread Commands+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Thread-Commands.html>+  thread_info,+  thread_list_ids,+  thread_select,++  -- ** Ada Tasking Commands+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Ada-Tasking-Commands.html>+  ada_task_info,++  -- ** Program Execution+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Program-Execution.html>+  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+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Stack-Manipulation.html>+  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+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Variable-Objects.html>+  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+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Data-Manipulation.html>+  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+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Tracepoint-Commands.html>+  trace_find,+  trace_define_variable,+  trace_list_variables,+  trace_save,+  trace_start,+  trace_status,+  trace_stop,++  -- ** Symbol Query+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Symbol-Query.html>+  symbol_list_lines,++  -- ** File Commands+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-File-Commands.html>+  file_exec_and_symbols,+  file_exec_file,+  file_list_exec_source_file,+  file_list_exec_source_files,+  file_symbol_file,++  -- ** Target Manipulation+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Target-Manipulation.html>+  target_attach,+  target_detach,+  target_disconnect,+  target_download,+  target_select,++  -- ** File Transfer Commands+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-File-Transfer-Commands.html>+  target_file_put,+  target_file_get,+  target_file_delete,++  -- ** Miscellaneous Commmands+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Miscellaneous-Commands.html>+  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+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/Specify-Location.html>.+  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.+-- <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Input-Syntax.html>+--+-- 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)

@@ -0,0 +1,239 @@+-- | Control execution of a GDB instance, send commands and receive results, notifications and stream information.+--+-- Due to <http://sourceware.org/bugzilla/show_bug.cgi?id=8759> 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

@@ -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+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Input-Syntax.html>+  Command(..),+  Token,+  Operation,+  Option(..),+  Parameter(..),+  -- ** Output+  -- | <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Output-Syntax.html>+  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 <http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI-Input-Syntax.html>+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

@@ -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

@@ -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+  }

@@ -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 <stdio.h>++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

@@ -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 <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' = 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)..]