Browse files

Merge branch 'hgdbmi'

  • Loading branch information...
2 parents 095b85d + f3e1b6e commit c7166eab0187868a52a61017c6d3687e5a1a6162 Alexander Bernauer committed Jan 5, 2013
View
38 ocram/ocram.cabal
@@ -22,25 +22,25 @@ Executable ocram
Default-Language: Haskell98
Default-extensions:
Build-Depends:
- base >= 4 && < 5,
- language-c == 0.5.*,
- containers == 0.4.*,
- mtl == 1.1.*,
- fgl == 5.4.*,
- syb == 0.3.*,
- process == 1.1.*,
- template-haskell,
- bytestring == 0.9.*,
- pretty == 1.2,
- regex-posix == 0.95.*,
- filepath == 1.3.*,
- directory == 1.1.*,
- nano-md5 == 0.1.*,
- json == 0.5.*,
- MissingH == 1.1.*,
- HUnit == 1.2.*,
- test-framework == 0.6.*,
+ base >= 4 && < 5,
+ language-c == 0.5.*,
+ containers == 0.4.*,
+ mtl == 1.1.*,
+ fgl == 5.4.*,
+ syb == 0.3.*,
+ process == 1.1.*,
+ bytestring == 0.9.*,
+ pretty == 1.2,
+ regex-posix == 0.95.*,
+ filepath == 1.3.*,
+ directory == 1.1.*,
+ nano-md5 == 0.1.*,
+ json == 0.5.*,
+ MissingH == 1.1.*,
+ HUnit == 1.2.*,
+ test-framework == 0.6.*,
test-framework-hunit == 0.2.*,
- hoopl == 3.8.7.4
+ hoopl == 3.8.7.4,
+ template-haskell
Other-modules:
Main
View
35 ruab/ruab.cabal
@@ -24,24 +24,25 @@ Executable ruab
Main-is: Main.hs
Default-Language: Haskell98
Build-Depends:
- base >= 4 && < 5,
- bytestring == 0.9.*,
- containers == 0.4.*,
- template-haskell,
- gtk == 0.12.*,
- glade == 0.12.*,
- HUnit == 1.2.*,
- test-framework == 0.6.*,
+ base >= 4 && < 5,
+ bytestring == 0.9.*,
+ containers == 0.4.*,
+ gtk == 0.12.*,
+ glade == 0.12.*,
+ HUnit == 1.2.*,
+ test-framework == 0.6.*,
test-framework-hunit == 0.2.*,
- process == 1.1.*,
- nano-md5 == 0.1.*,
- json == 0.5.*,
- parsec == 3.1.*,
- unix == 2.5.*,
- stm == 2.3.*,
- filepath == 1.3.*,
- language-c == 0.5.*,
- syb == 0.3.6.1
+ nano-md5 == 0.1.*,
+ json == 0.5.*,
+ filepath == 1.3.*,
+ language-c == 0.5.*,
+ syb == 0.3.*,
+ hgdbmi == 0.2.*,
+-- process == 1.1.*,
+-- parsec == 3.1.*,
+-- unix == 2.5.*,
+ stm == 2.3.*,
+ template-haskell
Other-Modules:
Main,
Ocram.Ruab,
View
11 ruab/src/Ruab/Backend/GDB.hs
@@ -16,14 +16,15 @@ import Control.Monad (when, guard)
import Prelude hiding (interact)
import Ruab.Util (abort)
-import qualified Ruab.Backend.GDB.Commands as G
-import qualified Ruab.Backend.GDB.IO as G
-import qualified Ruab.Backend.GDB.Responses as G
-import qualified Ruab.Backend.GDB.Representation as G
+import qualified Gdbmi.Commands as G
+import qualified Gdbmi.IO as G
+import qualified Gdbmi.Semantics as G
+import qualified Gdbmi.Representation as G
setup :: Maybe FilePath -> FilePath -> G.Callback -> IO G.Context -- {{{1
setup logfile binary callback = do
- ctx <- G.setup logfile callback
+ let config = G.Config (words "schroot -c quantal -p -- gdb") logfile
+ ctx <- G.setup config callback
resp <- G.send_command ctx (G.CLICommand Nothing "tty /dev/null") -- http://sourceware.org/bugzilla/show_bug.cgi?id=8759
when (G.respClass resp /= G.RCDone)
View
619 ruab/src/Ruab/Backend/GDB/Commands.hs
@@ -1,619 +0,0 @@
-module Ruab.Backend.GDB.Commands where
-
--- imports {{{1
-import Data.Maybe (fromMaybe)
-import Prelude hiding (reverse, all, lines)
-import Ruab.Backend.GDB.Representation hiding (Exec, Console)
-import Ruab.Util (replace)
-
--- types {{{1
-class GdbShow a where -- {{{2
- gdbShow :: a -> String
-
-instance GdbShow Char where
- gdbShow = (:[])
-
-instance GdbShow a => GdbShow [a] where
- gdbShow = concatMap gdbShow
-
-instance GdbShow Int where
- gdbShow = show
-
-type Location = String -- {{{2
-
-positive_offset_location :: Int -> Location -- {{{3
-positive_offset_location offset = "+" ++ gdbShow offset
-
-negative_offset_location :: Int -> Location -- {{{3
-negative_offset_location offset = "-" ++ gdbShow offset
-
-file_line_location :: String -> Int -> Location -- {{{3
-file_line_location filename linenum = filename ++ ":" ++ gdbShow linenum
-
-function_location :: String -> Location -- {{{3
-function_location = id
-
-function_label_location :: String -> String -> Location -- {{{3
-function_label_location function label = function ++ ":" ++ label
-
-file_function_location :: String -> String -> Location -- {{{3
-file_function_location filename function = filename ++ ":" ++ function
-
-label_location :: String -> Location -- {{{3
-label_location = id
-
-plain_address_location :: String -> Location -- {{{3
-plain_address_location = ("*"++)
-
-expr_address_location :: String -> Location -- {{{3
-expr_address_location = plain_address_location
-
-func_address_location :: String -> Location -- {{{3
-func_address_location = plain_address_location
-
-file_func_address_location :: String -> String -> Location -- {{{3
-file_func_address_location filename funcaddr = "'" ++ filename ++ "'::" ++ funcaddr
-
-data PrintValues -- {{{2
- = NoValues
- | AllValues
- | SimpleValues
-
-instance GdbShow PrintValues where
- gdbShow NoValues = "--no-values"
- gdbShow AllValues = "--all-values"
- gdbShow SimpleValues = "--simple-values"
-
-mapPrintValues :: (PrintValues -> a) -> Int -> a
-mapPrintValues f 0 = f NoValues
-mapPrintValues f 1 = f AllValues
-mapPrintValues f 2 = f SimpleValues
-mapPrintValues _ _ = error "valid integers for the print-value parameter range from 0 to 2 only"
-
-data FrameSelect -- {{{2
- = FrameAddr String
- | CurrentFrame
- | Floating
-
-instance GdbShow FrameSelect where
- gdbShow (FrameAddr addr) = addr
- gdbShow CurrentFrame = "*"
- gdbShow Floating = "@"
-
-data FormatSpec -- {{{2
- = Binary
- | Decimal
- | Hexadecimal
- | Octal
- | Natural
-
-instance GdbShow FormatSpec where
- gdbShow Binary = "binary"
- gdbShow Decimal = "decimal"
- gdbShow Hexadecimal = "hexadecimal"
- gdbShow Octal = "octal"
- gdbShow Natural = "natural"
-
-data FrozenFlag -- {{{2
- = Frozen
- | Unfrozen
-
-instance GdbShow FrozenFlag where
- gdbShow Frozen = "1"
- gdbShow Unfrozen = "0"
-
-data DisassemblyMode -- {{{2
- = DisassemblyMode Bool Bool -- mixed source and disassembly, raw opcodes
-
-instance GdbShow DisassemblyMode where
- gdbShow (DisassemblyMode False False) = "0"
- gdbShow (DisassemblyMode True False) = "1"
- gdbShow (DisassemblyMode False True) = "2"
- gdbShow (DisassemblyMode True True) = "3"
-
-data DataFormat -- {{{2
- = DHexadecimal
- | DOctal
- | DBinary
- | DDecimal
- | DRaw
- | DNatural
-
-instance GdbShow DataFormat where
- gdbShow DHexadecimal = "x"
- gdbShow DOctal = "o"
- gdbShow DBinary = "t"
- gdbShow DDecimal = "d"
- gdbShow DRaw = "r"
- gdbShow DNatural = "N"
-
-data OutputFormat -- {{{2
- = HexadecimalInteger
- | SignedDecimalInteger
- | UnsignedDecimalInteger
- | OctalInteger
- | BinaryInteger
- | Address
- | CharacterConstantInteger
- | FloatingPointNumber
- | OString
- | Raw
-
-instance GdbShow OutputFormat where
- gdbShow HexadecimalInteger = "x"
- gdbShow SignedDecimalInteger = "d"
- gdbShow UnsignedDecimalInteger = "u"
- gdbShow OctalInteger = "o"
- gdbShow BinaryInteger = "t"
- gdbShow Address = "a"
- gdbShow CharacterConstantInteger = "c"
- gdbShow FloatingPointNumber = "f"
- gdbShow OString = "s"
- gdbShow Raw = "r"
-
-data TraceMode -- {{{2
- = None
- | FrameNumber Int
- | TracepointNumber Int
- | PC String
- | PCInsideRange String String
- | PCOutsideRange String String
- | Line Location
-
-instance GdbShow TraceMode where
- gdbShow None = "none"
- gdbShow (FrameNumber _) = "frame-number"
- gdbShow (TracepointNumber _) = "tracepoint-number"
- gdbShow (PC _) = "pc"
- gdbShow (PCInsideRange _ _) = "pc-inside-range"
- gdbShow (PCOutsideRange _ _) = "pc-outside-range"
- gdbShow (Line _) = "line"
-
-traceModeOptions :: TraceMode -> [Option]
-traceModeOptions None = []
-traceModeOptions (FrameNumber x) = [opt x]
-traceModeOptions (TracepointNumber x) = [opt x]
-traceModeOptions (PC x) = [opt x]
-traceModeOptions (PCInsideRange x y) = [opt x, opt y]
-traceModeOptions (PCOutsideRange x y) = [opt x, opt y]
-traceModeOptions (Line x) = [opt x]
-
-data Target -- {{{2
- = Exec FilePath
- | Core FilePath
- | Remote Medium
- | Sim [String]
- | Nrom
-
-instance GdbShow Target where
- gdbShow (Exec _) = "exec"
- gdbShow (Core _) = "core"
- gdbShow (Remote _) = "remote"
- gdbShow (Sim _) = "sim"
- gdbShow Nrom = "nrom"
-
-targetOptions :: Target -> [Option]
-targetOptions (Exec x) = [opt x]
-targetOptions (Core x) = [opt x]
-targetOptions (Remote x) = [opt x]
-targetOptions (Sim xs) = map opt xs
-targetOptions Nrom = []
-
-data Medium -- {{{2
- = SerialDevice String
- | TcpHost String Int
- | UdpHost String Int
- | Pipe String
-
-instance GdbShow Medium where
- gdbShow (SerialDevice device) = device
- gdbShow (TcpHost host port) = "tcp:" ++ host ++ ":" ++ gdbShow port
- gdbShow (UdpHost host port) = "udp:" ++ host ++ ":" ++ gdbShow port
- gdbShow (Pipe command) = "| " ++ command
-
-data Interpreter -- {{{2
- = Console
- | MI
- | MI2
- | MI1
-
-instance GdbShow Interpreter where
- gdbShow Console = "console"
- gdbShow MI = "mi"
- gdbShow MI2 = "mi2"
- gdbShow MI1 = "mi1"
-
--- helper {{{1
-add_token :: Token -> Command -> Command -- {{{2
-add_token token (MICommand _ x y z) = MICommand (Just token) x y z
-add_token token (CLICommand _ x) = CLICommand (Just token) x
-
--- add_parameters :: [Parameter] -> Command -> Command -- {{{2
--- add_parameters ps (MICommand x y z ps') = MICommand x y z (ps'++ps)
--- add_parameters ps (CLICommand t s) = CLICommand t (s ++ intercalate " " ps)
-
--- commands {{{1
--- breakpoint commands {{{2
-break_after :: Int -> Int -> Command -- {{{3
-break_after number count = cmd "break-after" $ map opt [number, count]
-
-break_commands :: Int -> [String] -> Command -- {{{3
-break_commands number commands = cmd "break-commands" $ opt number : map opt commands
-
-break_condition :: Int -> String -> Command -- {{{3
-break_condition number expr = cmd "break-condition" $ opt number : opt expr : []
-
-break_delete :: [Int] -> Command -- {{{3
-break_delete numbers = cmd "break-delete" $ map optr numbers
-
-break_disable :: [Int] -> Command -- {{{3
-break_disable numbers = cmd "break-disable" $ map opt numbers
-
-break_enable :: [Int] -> Command -- {{{3
-break_enable numbers = cmd "break-enable" $ map opt numbers
-
-break_info :: Int -> Command -- {{{3
-break_info number = cmd "break-info" [opt number]
-
-break_insert :: Bool -> Bool -> Bool -> Bool -> Bool -> Maybe String -> Maybe Int -> Maybe Int -> Location -> Command -- {{{3
-break_insert temporary hardware pending disabled tracepoint condition ignoreCount threadId location =
- cmd "break-insert" $ temporary' ?: hardware' ?: pending' ?: disabled' ?: tracepoint' ?: condition' ?: ignoreCount' ?: threadId' ?: opt location : []
- where
- temporary' = flagOpt "-t" temporary
- hardware' = flagOpt "-h" hardware
- pending' = flagOpt "-p" pending
- disabled' = flagOpt "-d" disabled
- tracepoint' = flagOpt "-a" tracepoint
- condition' = valueOpt "-c" condition
- ignoreCount' = valueOpt "-i" ignoreCount
- threadId' = valueOpt "-p" threadId
-
-break_list :: Command -- {{{3
-break_list = cmd "break-list" []
-
-break_passcount :: Int -> Int -> Command -- {{{3
-break_passcount tracepointNumber passcount = cmd "break-passcount" $ map opt [tracepointNumber, passcount]
-
-break_watch :: Bool -> Command -- {{{3
-break_watch access = cmd "break-watch" [opt (if access then "-a" else "-r")]
-
--- program context {{{2
-exec_arguments :: [String] -> Command -- {{{3
-exec_arguments args = cmd "exec-arguments" $ map opt args
-
-environment_cd :: String -> Command -- {{{3
-environment_cd pathdir = cmd "environment-cd" [opt pathdir]
-
-environment_directory :: Bool -> [String] -> Command -- {{{3
-environment_directory reset pathdirs = cmd "environment-directory" $ flagOpt "-r" reset ?: map opt pathdirs
-
-environment_path :: Bool -> [String] -> Command -- {{{3
-environment_path reset pathdirs = cmd "environment-path" $ flagOpt "-r" reset ?: map opt pathdirs
-
-environment_pwd :: Command -- {{{3
-environment_pwd = cmd "environment-pwd" []
-
--- thread commands {{{2
-thread_info :: Maybe Int -> Command -- {{{3
-thread_info threadId = cmd "thread-info" $ fmap opt threadId ?: []
-
-thread_list_ids :: Command -- {{{3
-thread_list_ids = cmd "thread-list-ids" []
-
-thread_select :: Int -> Command -- {{{3
-thread_select threadnum = cmd "thread-select" [opt threadnum]
-
--- ada tasking commands -- TODO {{{2
-
--- program execution {{{2
-exec_continue :: Bool -> Either Bool Int -> Command -- {{{3
-exec_continue reverse x = cmd "exec-continue" $ reverse' ?: x' ?: []
- where
- reverse' = flagOpt "--reverse" reverse
- x' = case x of
- Left all -> flagOpt "--all" all
- Right threadGroup -> Just $ opt' "--threadGroup" threadGroup
-
-exec_finish :: Bool -> Command -- {{{3
-exec_finish reverse = cmd "exec-finish" $ flagOpt "--reverse" reverse ?: []
-
-exec_interrupt :: Either Bool Int -> Command -- {{{3
-exec_interrupt x = cmd "exec-interrupt" $ x' ?: []
- where
- x' = case x of
- Left all -> flagOpt "-all" all
- Right threadGroup -> Just $ opt' "--threadGroup" threadGroup
-
-exec_jump :: Location -> Command -- {{{3
-exec_jump location = cmd "exec-jump" [opt location]
-
-exec_next :: Command -- {{{3
-exec_next = cmd "exec-next" []
-
-exec_next_instruction :: Bool -> Command -- {{{3
-exec_next_instruction reverse = cmd "exec-next-instruction" $ flagOpt "--reverse" reverse ?: []
-
-exec_return :: Command -- {{{3
-exec_return = cmd "exec-return" []
-
-exec_run :: Either Bool Int -> Command -- {{{3
-exec_run x = cmd "exec-run" $ x' ?: []
- where
- x' = case x of
- Left all -> flagOpt "-all" all
- Right threadGroup -> Just $ opt' "--threadGroup" threadGroup
-
-exec_step :: Command -- {{{3
-exec_step = cmd "exec-step" []
-
-exec_step_instruction :: Bool -> Command -- {{{3
-exec_step_instruction reverse = cmd "exec-step-instruction" $ flagOpt "--reverse" reverse ?: []
-
-exec_until :: Location -> Command -- {{{3
-exec_until location = cmd "exec-until" [opt location]
-
--- stack manipulation {{{2
-stack_info_frame :: Command -- {{{3
-stack_info_frame = cmd "stack-info-frame" []
-
-stack_info_depth :: Maybe Int -> Command -- {{{3
-stack_info_depth maxDepth = cmd "stack-info-depth" $ fmap opt maxDepth ?: []
-
-stack_list_arguments :: PrintValues -> Maybe (Int, Int) -> Command -- {{{3
-stack_list_arguments printValues frames = cmd "stack-list-arguments" $ opt printValues : maybTupleOpt frames
-
-stack_list_arguments' :: Int -> Maybe (Int, Int) -> Command
-stack_list_arguments' = mapPrintValues stack_list_arguments
-
-stack_list_frames :: Maybe (Int, Int) -> Command -- {{{3
-stack_list_frames frames = cmd "stack-list-frames" $ maybTupleOpt frames
-
-stack_list_locals :: PrintValues -> Command -- {{{3
-stack_list_locals printValues = cmd "stack-list-locals" [opt printValues]
-
-stack_list_locals' :: Int -> Command -- {{{3
-stack_list_locals' = mapPrintValues stack_list_locals
-
-stack_list_variables :: PrintValues -> Command -- {{{3
-stack_list_variables printValues = cmd "stack-list-variable" [opt printValues]
-
-stack_list_variables' :: Int -> Command -- {{{3
-stack_list_variables' = mapPrintValues stack_list_variables
-
-stack_select_frame :: Int -> Command -- {{{3
-stack_select_frame framenum = cmd "stack-select-frame" [opt framenum]
-
--- variable objects {{{2
-enable_pretty_printing :: Command -- {{{3
-enable_pretty_printing = cmd "enable-pretty-printing" []
-
-var_create :: Maybe String -> FrameSelect -> String -> Command -- {{{3
-var_create name frameSelect expression = cmd "var-create" $ [name', opt frameSelect, opt expression]
- where
- name' = opt (fromMaybe "-" name)
-
-var_delete :: Bool -> String -> Command -- {{{3
-var_delete children name = cmd "var-delete" $ flagOpt "-c" children ?: opt name : []
-
-var_set_format :: String -> FormatSpec -> Command -- {{{3
-var_set_format name formatSpec = cmd "var-set-format" [opt name, opt formatSpec]
-
-var_gdbShow_format :: String -> Command -- {{{3
-var_gdbShow_format name = cmd "var-gdbShow-format" [opt name]
-
-var_info_num_children :: String -> Command -- {{{3
-var_info_num_children name = cmd "var-info-num-children" [opt name]
-
-var_list_children :: Maybe PrintValues -> String -> Maybe (Int, Int) -> Command -- {{{3
-var_list_children Nothing name range = var_list_children (Just NoValues) name range
-var_list_children (Just printValues) name range = cmd "var-list-children" $ opt printValues : opt name : maybTupleOpt range
-
-var_list_children' :: Int -> String -> Maybe (Int, Int) -> Command
-var_list_children' = mapPrintValues (var_list_children . Just)
-
-var_info_type :: Command -- {{{3
-var_info_type = cmd "var-info-type" []
-
-var_info_expression :: String -> Command -- {{{3
-var_info_expression name = cmd "var-info-expression" [opt name]
-
-var_info_path_expressoin :: String -> Command -- {{{3
-var_info_path_expressoin name = cmd "var-info-path-expression" [opt name]
-
-var_gdbShow_attributes :: String -> Command -- {{{3
-var_gdbShow_attributes name = cmd "var-gdbShow-attributes" [opt name]
-
-var_evaluate_expression :: Maybe FormatSpec -> String -> Command -- {{{3
-var_evaluate_expression formatSpec name = cmd "var-evaluate-expression" $ valueOpt "-f" formatSpec ?: opt name : []
-
-var_assign :: String -> String -> Command -- {{{3
-var_assign name expression = cmd "var-assign" [opt name, opt expression]
-
-var_update :: Maybe PrintValues -> Maybe String -> Command -- {{{3
-var_update Nothing name = var_update (Just NoValues) name
-var_update (Just printValues) name = cmd "var-update" $ opt printValues : fmap opt name ?: []
-
-var_set_frozen :: String -> FrozenFlag -> Command -- {{{3
-var_set_frozen name flag = cmd "var-set-frozen" [opt name, opt flag]
-
-var_set_update_range :: String -> Int -> Int -> Command -- {{{3
-var_set_update_range name from to = cmd "var-set-update-range" [opt name, opt from, opt to]
-
-var_set_visualizer :: String -> String -> Command -- {{{3
-var_set_visualizer name visualizer = cmd "ver-set-visualizer" [opt name, opt visualizer]
-
--- data manipulation {{{2
-data_disassemble :: Either (String, String) (String, Int, Maybe Int) -> DisassemblyMode -> Command -- {{{3
-data_disassemble x mode = MICommand Nothing "data-disassemble" options [QuotedString . gdbShow $ mode]
- where
- options = case x of
- Left (start, end) -> opt' "-s" start : opt' "-e" end : []
- Right (filename, linenum, lines) -> opt' "-f" filename : opt' "-l" linenum : valueOpt "-n" lines ?: []
-
-data_evaluate_expression :: String -> Command -- {{{3
-data_evaluate_expression expr = cmd "data-evaluate-expression" [opt expr]
-
-data_list_changed_registers :: Command -- {{{3
-data_list_changed_registers = cmd "data-list-changed-registers" []
-
-data_list_register_names :: [Int] -> Command -- {{{3
-data_list_register_names regnos = cmd "data-list-register-names" $ map opt regnos
-
-data_list_register_values :: DataFormat -> [Int] -> Command -- {{{3
-data_list_register_values fmt regnos = cmd "data-list-register-values" $ opt fmt : map opt regnos
-
-data_read_memory :: Maybe Int -> String -> OutputFormat -> Int -> Int -> Int -> Maybe Char -> Command -- {{{3
-data_read_memory byteOffset address wordFormat wordSize nrRows nrCols asChar =
- cmd "data-read-memory" $ valueOpt "-o" byteOffset ?: opt address : opt wordFormat : opt wordSize : opt nrRows : opt nrCols : fmap opt asChar ?: []
-
-data_read_memory_bytes :: Maybe Int -> String -> Int -> Command -- {{{3
-data_read_memory_bytes byteOffset address count = cmd "data-read-memory-bytes" $ valueOpt "-o" byteOffset ?: opt address : opt count : []
-
-data_write_memory_bytes :: String -> String -> Command -- {{{3
-data_write_memory_bytes address contents = cmd "data-write-memory-bytes" [opt address, opt contents]
-
--- tracepoint commands {{{2
-trace_find :: TraceMode -> Command -- {{{3
-trace_find traceMode = cmd "trace-find" $ opt traceMode : traceModeOptions traceMode
-
-trace_define_variable :: String -> Maybe String -> Command -- {{{3
-trace_define_variable name value = cmd "trace-define-variable" $ opt name : fmap opt value ?: []
-
-trace_list_variables :: Command -- {{{3
-trace_list_variables = cmd "trace-list-variables" []
-
-trace_save :: Bool -> String -> Command -- {{{3
-trace_save remote filename = cmd "trace-save" $ flagOpt "-r" remote ?: opt filename : []
-
-trace_start :: Command -- {{{3
-trace_start = cmd "trace-start" []
-
-trace_status :: Command -- {{{3
-trace_status = cmd "trace-status" []
-
-trace_stop :: Command -- {{{3
-trace_stop = cmd "trace-stop" []
-
--- symbol query {{{2
-
-symbol_list_lines :: String -> Command -- {{{3
-symbol_list_lines filename = cmd "symbol-list-lines" [opt filename]
-
--- file commands {{{2
-file_exec_and_symbols :: Maybe FilePath -> Command -- {{{3
-file_exec_and_symbols file = cmd "file-exec-and-symbols" $ fmap opt file ?: []
-
-file_exec_file :: Maybe FilePath -> Command -- {{{3
-file_exec_file file = cmd "file-exec-file" $ fmap opt file ?: []
-
-file_list_exec_source_file :: Command -- {{{3
-file_list_exec_source_file = cmd "file-list-exec-source-file" []
-
-file_list_exec_source_files :: Command -- {{{3
-file_list_exec_source_files = cmd "file-list-exec-source-files" []
-
-file_symbol_file :: Maybe FilePath -> Command -- {{{3
-file_symbol_file file = cmd "file-symbol-file" $ fmap opt file ?: []
-
--- target manipulation {{{2
-target_attach :: Either Int FilePath -> Command -- {{{3
-target_attach x = cmd "target-attach" $ x' : []
- where
- x' = case x of
- Left pidOrGid -> opt pidOrGid
- Right file -> opt file
-
-target_detach :: Maybe Int -> Command -- {{{3
-target_detach pidOrGid = cmd "target-detach" $ fmap opt pidOrGid ?: []
-
-target_disconnect :: Command -- {{{3
-target_disconnect = cmd "target-disconnect" []
-
-target_download :: Command -- {{{3
-target_download = cmd "target-download" []
-
-target_select :: Target -> Command -- {{{3
-target_select target = cmd "target-select" $ opt target : targetOptions target
-
--- file transfer commands {{{2
-target_file_put :: FilePath -> FilePath -> Command -- {{{3
-target_file_put hostfile targetfile = cmd "target-file-put" $ opt hostfile : opt targetfile : []
-
-target_file_get :: FilePath -> FilePath -> Command -- {{{3
-target_file_get targetfile hostfile = cmd "target-file-get" $ opt targetfile : opt hostfile : []
-
-target_file_delete :: FilePath -> Command -- {{{3
-target_file_delete targetfile = cmd "target-file-delete" $ opt targetfile : []
-
--- miscellaneous commmands {{{2
-gdb_exit :: Command -- {{{3
-gdb_exit = cmd "gdb-exit" []
-
-gdb_set :: String -> Command -- {{{3
-gdb_set expr = cmd "gdb-set" $ opt expr : []
-
-gdb_gdbShow :: String -> Command -- {{{3
-gdb_gdbShow name = cmd "gdb-gdbShow" $ opt name : []
-
-gdb_version :: Command -- {{{3
-gdb_version = cmd "gdb-version" []
-
-list_features :: Command -- {{{3
-list_features = cmd "list-features" []
-
-list_target_features :: Command -- {{{3
-list_target_features = cmd "list-target-features" []
-
-list_thread_groups :: Bool -> Maybe Int -> [Int] -> Command -- {{{3
-list_thread_groups available recurse groups = cmd "list-thread-groups" $ flagOpt "--available" available ?: valueOpt "--recurse" recurse ?: map opt groups
-
-info_os :: Maybe String -> Command -- {{{3
-info_os type_ = cmd "info-os" $ fmap opt type_ ?: []
-
-add_inferior :: Command -- {{{3
-add_inferior = cmd "add-inferior" []
-
-interpreter_exec :: Interpreter -> Command -> Command -- {{{3
-interpreter_exec interpreter command = cmd "interpreter-exec" $ opt interpreter : opt ((escapeQuotes . render_command) command) : []
-
-inferior_tty_set :: String -> Command -- {{{3
-inferior_tty_set tty = cmd "inferior-tty-set" $ opt tty : []
-
-inferior_tty_gdbShow :: Command -- {{{3
-inferior_tty_gdbShow = cmd "inferior-tty-gdbShow" []
-
-enable_timings :: Bool -> Command -- {{{3
-enable_timings flag = cmd "enable-timings" $ opt (if flag then "yes" else "no") : []
-
--- utils {{{1
-cmd :: String -> [Option] -> Command -- {{{2
-cmd operation options = MICommand Nothing operation options []
-
-opt :: GdbShow a => a -> Option -- {{{2
-opt parameter = Option (QuotedString . gdbShow $ parameter) Nothing
-
-optr :: Show a => a -> Option -- {{{2
-optr parameter = Option (RawString . show $ parameter) Nothing
-
-opt' :: (GdbShow a, GdbShow b) => a -> b -> Option -- {{{2
-opt' name value = Option (QuotedString . gdbShow $ name) (Just (QuotedString . gdbShow $ value))
-
-flagOpt :: String -> Bool -> Maybe Option -- {{{2
-flagOpt _ False = Nothing
-flagOpt flag True = Just (opt flag)
-
-valueOpt :: GdbShow a => String -> Maybe a -> Maybe Option -- {{{2
-valueOpt _ Nothing = Nothing
-valueOpt flag param = Just (Option (QuotedString flag) (fmap (QuotedString . gdbShow) param))
-
-maybTupleOpt :: GdbShow a => Maybe (a, a) -> [Option] -- {{{2
-maybTupleOpt Nothing = []
-maybTupleOpt (Just (lowFrame, highFrame)) = map opt [lowFrame, highFrame]
-
-(?:) :: Maybe a -> [a] -> [a] -- {{{1
-(Just x) ?: xs = x : xs
-Nothing ?: xs = xs
-infixr 5 ?:
-
-escapeQuotes :: String -> String -- {{{2
-escapeQuotes = replace '"' "\\\""
View
190 ruab/src/Ruab/Backend/GDB/IO.hs
@@ -1,190 +0,0 @@
-module Ruab.Backend.GDB.IO
--- exports {{{1
-(
- Context, Callback(..)
- , setup, shutdown, send_command
-) where
-
--- [The GDB/MI Interface](http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI)
--- GDB version 7.5
-
--- imports {{{1
-import Control.Applicative ((<*>), (<$>))
-import Control.Concurrent (forkIO, killThread, ThreadId, MVar, newEmptyMVar, tryTakeMVar, putMVar, takeMVar)
-import Control.Concurrent.STM (TVar, TChan, TMVar, newEmptyTMVar, newTVarIO, newTChanIO, atomically, takeTMVar, readTVar, writeTVar, writeTChan, readTChan, putTMVar)
-import Control.Exception (catchJust)
-import Control.Exception.Base (AsyncException(ThreadKilled))
-import Control.Monad (replicateM_)
-import Control.Monad.Fix (mfix)
-import Data.List (partition)
-import Prelude hiding (catch, interact)
-import System.IO (Handle, hSetBuffering, BufferMode(LineBuffering), hPutStr, hWaitForInput, hGetLine, IOMode(WriteMode), stdout, openFile, hFlush)
-import System.Posix.IO (fdToHandle, createPipe)
-import System.Process (ProcessHandle, runProcess, waitForProcess)
-
-import qualified Ruab.Backend.GDB.Commands as C
-import qualified Ruab.Backend.GDB.Representation as R
-import qualified Ruab.Backend.GDB.Responses as S
-
-data Context = Context { -- {{{1
--- gdb process {{{2
- ctxProcess :: ProcessHandle
- , ctxCommandPipe :: Handle
- , ctxOutputPipe :: Handle
- , ctxLog :: Maybe Handle
--- callback
- , ctxCallback :: Callback
--- threads
- , ctxCommandThread :: ThreadId
- , ctxOutputThread :: ThreadId
- , ctxCurrentJob :: MVar Job
- , ctxFinished :: MVar ()
--- jobs
- , ctxNextToken :: TVar R.Token
- , ctxJobs :: TChan Job
-}
-
-data Job = Job {
- jobCommand :: R.Command
- , jobResponse :: TMVar R.Response
- , jobToken :: R.Token
- }
-
-data Callback -- {{{1
- = Callback {
- cbStream :: R.Stream -> IO ()
- , cbStopped :: S.Stopped -> IO ()
- , cbNotify :: R.Notification -> IO ()
- }
-
-setup :: Maybe FilePath -> Callback -> IO Context -- {{{1
-setup logfile callback = do
- (commandR, commandW) <- createPipe >>= asHandles
- (outputR, outputW) <- createPipe >>= asHandles
- phandle <- runProcess "setsid" (words "schroot -c quantal -p -- gdb --interpreter mi") -- avoid receiving SIGINTs when issuing -exec-interrupt
- Nothing Nothing
- (Just commandR)
- (Just outputW)
- Nothing
- mapM_ (`hSetBuffering` LineBuffering) [commandW, outputR]
- logH <- case logfile of
- Nothing -> return Nothing
- Just "-" -> return $ Just stdout
- Just f -> fmap Just $ openFile f WriteMode
- currentJob <- newEmptyMVar
- finished <- newEmptyMVar
- nextToken <- newTVarIO 0
- jobs <- newTChanIO
- ctx <- mfix (\ctx -> do
- itid <- forkIO (handleCommands ctx)
- otid <- forkIO (handleOutput ctx)
- return $ Context phandle commandW outputR logH callback itid otid currentJob finished nextToken jobs
- )
- return ctx
- where
- asHandles (f1, f2) = do
- h1 <- fdToHandle f1
- h2 <- fdToHandle f2
- return (h1, h2)
-
-shutdown :: Context -> IO () -- {{{1
-shutdown ctx = do
- mapM_ (killThread . ($ctx)) [ctxCommandThread, ctxOutputThread]
- replicateM_ 2 (takeMVar (ctxFinished ctx))
- writeCommand ctx C.gdb_exit 0
- _ <- waitForProcess (ctxProcess ctx)
- putMVar (ctxFinished ctx) ()
- return ()
-
-send_command :: Context -> R.Command -> IO R.Response -- {{{1
-send_command ctx command = checkShutdown >> sendCommand >>= receiveResponse
- where
- checkShutdown = do
- finished <- tryTakeMVar (ctxFinished ctx)
- case finished of
- Nothing -> return ()
- Just () -> error "context has already been shut down"
-
- sendCommand = atomically $ do
- token <- readTVar (ctxNextToken ctx)
- writeTVar (ctxNextToken ctx) (if token == maxBound then 0 else token + 1)
- response <- newEmptyTMVar
- writeTChan (ctxJobs ctx) $ Job command response token
- return response
-
- receiveResponse = atomically . takeTMVar
-
-
--- implementation {{{1
-handleCommands :: Context -> IO () -- {{{2
-handleCommands ctx = handleKill ctx $ do
- job <- atomically $ readTChan (ctxJobs ctx)
- putMVar (ctxCurrentJob ctx) job
- writeCommand ctx (jobCommand job) (jobToken job)
- handleCommands ctx
-
-handleOutput :: Context -> IO () -- {{{2
-handleOutput ctx = handleKill ctx $ do
- output <- readOutput ctx
- _ <- forkIO $
- let
- streams = R.output_stream output
- notifications = R.output_notification output
- (stops, others) = partition ((&&) <$> (R.Exec==) . R.notiClass <*> (R.ACStop==) . R.notiAsyncClass) notifications
- Just stops' = sequence $ map (S.response_stopped . R.notiResults) stops
- in do
- mapM_ ((cbStream . ctxCallback) ctx) streams
- mapM_ ((cbNotify . ctxCallback) ctx) others
- mapM_ ((cbStopped . ctxCallback) ctx) stops'
- case R.output_response output of
- Nothing -> return ()
- Just response -> do
- maybJob <- tryTakeMVar (ctxCurrentJob ctx)
- case maybJob of
- Nothing -> error "result record lost!"
- Just job ->
- if (R.get_token output /= Just (jobToken job))
- then error $ "token missmatch! " ++ show (R.get_token output) ++ " vs. " ++ show (jobToken job)
- else atomically $ putTMVar (jobResponse job) response
- handleOutput ctx
-
-handleKill :: Context -> IO () -> IO ()
-handleKill ctx action = catchJust select action handler
- where
- select :: AsyncException -> Maybe ()
- select ThreadKilled = Just ()
- select _ = Nothing
-
- handler :: () -> IO ()
- handler _ = putMVar (ctxFinished ctx) ()
-
-writeCommand :: Context -> R.Command -> R.Token -> IO () -- {{{2
-writeCommand ctx cmd token =
- let cmdstr = (R.render_command . C.add_token token) cmd in
- do
- debugLog ctx True cmdstr
- hPutStr (ctxCommandPipe ctx) cmdstr
-
-readOutput :: Context -> IO R.Output -- {{{2
-readOutput ctx = do
- _ <- hWaitForInput (ctxOutputPipe ctx) (-1)
- str <- outputString (ctxOutputPipe ctx)
- debugLog ctx False str
- return (R.parse_output str)
- where
- outputString handle = outputLines handle >>= return . unlines
- outputLines handle = do
- line <- hGetLine handle
- if line == "(gdb) "
- then return [line]
- else outputLines handle >>= return . (line:)
-
-debugLog :: Context -> Bool -> String -> IO () -- {{{2
-debugLog ctx io text =
- let
- prefix = if io then "/i " else "/o "
- line = ((unlines . map (prefix++) . lines) text)
- in
- case (ctxLog ctx) of
- Nothing -> return ()
- Just h -> hPutStr h line >> hFlush h
View
442 ruab/src/Ruab/Backend/GDB/Representation.hs
@@ -1,442 +0,0 @@
-module Ruab.Backend.GDB.Representation where
-
--- imports {{{1
-import Control.Applicative ((<$>), (<*>), (<*))
-import Data.Char (isAscii)
-import Data.List (find)
-import Data.Maybe (isNothing)
-import Text.ParserCombinators.Parsec hiding (token)
-
--- input {{{1
--- types {{{2
-data Command -- {{{3
- = CLICommand (Maybe Token) String
- | MICommand (Maybe Token) Operation [Option] [Parameter]
-
-type Operation = String -- {{{3
-
-data Option = Option Parameter (Maybe Parameter) -- {{{3
-
-data Parameter -- {{{3
- -- the documentation does not specify this, but de-facto some parameters have
- -- to be quoted and other must not
- = RawString String
- | QuotedString String
-
--- rendering {{{2
-render_command :: Command -> String -- {{{3
-render_command cmd = r_command cmd ""
-
-r_command :: Command -> ShowS -- {{{3
-r_command (CLICommand tok str) = maybe id r_token tok . showString str . showString "\n"
-r_command (MICommand tok operation options parameters) =
- maybe id shows tok
- . showString "-" . r_operation operation
- . foldl (\f o -> f . showString " " . r_option o) id options
- . (if null parameters
- then id
- else showString " --" . foldl (\f p -> f . showString " " . r_parameter p) id parameters)
- . showString "\n"
-
-r_operation :: Operation -> ShowS -- {{{3
-r_operation op = (op++)
-
-r_option :: Option -> ShowS -- {{{3
- -- the documentation specifies a "-" before each option but some operations
- -- such as file-exec-and-symbols are not happy with this :-/
-r_option (Option p p') =
- r_parameter p
- . maybe id (\x -> showString " " . r_parameter x) p'
-
-r_parameter :: Parameter -> ShowS -- {{{3
-r_parameter (RawString s) = showString s
-r_parameter (QuotedString s) = shows s
-
-r_token :: Token -> ShowS -- {{{3
-r_token = shows
-
--- output {{{1
--- types {{{2
-data Output -- {{{3
- = Output [OutOfBandRecord] (Maybe ResultRecord)
- deriving Show
-
-data ResultRecord -- {{{3
- = ResultRecord (Maybe Token) ResultClass [Result]
- deriving Show
-
-data OutOfBandRecord -- {{{3
- = OOBAsyncRecord AsyncRecord
- | OOBStreamRecord StreamRecord
- deriving Show
-
-data AsyncRecord -- {{{3
- = ARExecAsyncOutput ExecAsyncOutput
- | ARStatusAsyncOutput StatusAsyncOutput
- | ARNotifyAsyncOutput NotifyAsyncOutput
- deriving Show
-
-data ExecAsyncOutput -- {{{3
- = ExecAsyncOutput (Maybe Token) AsyncOutput
- deriving Show
-
-data StatusAsyncOutput -- {{{3
- = StatusAsyncOutput (Maybe Token) AsyncOutput
- deriving Show
-
-data NotifyAsyncOutput -- {{{3
- = NotifyAsyncOutput (Maybe Token) AsyncOutput
- deriving Show
-
-data AsyncOutput -- {{{3
- = AsyncOutput AsyncClass [Result]
- deriving Show
-
-data ResultClass -- {{{3
- = RCDone
- | RCRunning
- | RCConnected
- | RCError
- | RCExit
- deriving (Show, Eq)
-
-data AsyncClass -- {{{3
--- much more stuff than the documentation specifies
- = ACStop
- | ACThreadGroupAdded
- | ACThreadGroupStarted
- | ACThreadCreated
- | ACRunning
- | ACLibraryLoaded
- | ACThreadExited
- | ACThreadGroupExited
- | ACBreakpointModified
- deriving (Show, Eq)
-
-data Result -- {{{3
- = Result {
- resVariable :: Variable
- , resValue :: Value
- }
- deriving Show
-
-type Variable = String -- {{{3
-
-data Value -- {{{3
- = VConst Const
- | VTuple Tuple
- | VList List
- deriving Show
-
-type Const = CString -- {{{3
-
-data Tuple -- {{{3
- = Tuple {
- tupleResults :: [Result]
- }
- deriving Show
-
-data List -- {{{3
- = EmptyList
- | ValueList [Value]
- | ResultList [Result]
- deriving Show
-
-data StreamRecord -- {{{3
- = SRConsoleStreamOutput ConsoleStreamOutput
- | SRTargetStreamOutput TargetStreamOutput
- | SRLogStreamOutput LogStreamOutput
- deriving Show
-
-data ConsoleStreamOutput -- {{{3
- = ConsoleStreamOutput CString
- deriving Show
-
-data TargetStreamOutput -- {{{3
- = TargetStreamOutput CString
- deriving Show
-
-data LogStreamOutput -- {{{3
- = LogStreamOutput CString
- deriving Show
-
-type CString = String -- {{{3
-
--- parsing {{{2
-parse_output :: String -> Output -- {{{3
-parse_output str = case parse p_output "gdb" str of
- Left pe -> error $ "parse failed: " ++ show pe
- Right o -> o
-
-p_output :: Parser Output -- {{{3
--- http://sourceware.org/bugzilla/show_bug.cgi?id=7708
--- p_output = Output <$> many p_outOfBandRecord <*> optionMaybe p_resultRecord <* string "(gdb) " <* newline <* eof
-p_output = do
- oob <- many p_outOfBandRecord
- rr <- optionMaybe p_resultRecord
- oob' <- many p_outOfBandRecord
- string "(gdb) " >> newline >> eof
- return $ Output (oob ++ oob') rr
-
-p_resultRecord :: Parser ResultRecord -- {{{3
-p_resultRecord =
- ResultRecord <$> optionMaybe p_token <* char '^' <*> p_resultClass <*> many (char ',' >> p_result) <* newline
-
-p_outOfBandRecord :: Parser OutOfBandRecord -- {{{3
-p_outOfBandRecord =
- try (p_asyncRecord >>= return . OOBAsyncRecord)
- <|> (p_streamRecord >>= return . OOBStreamRecord)
-
-p_asyncRecord :: Parser AsyncRecord -- {{{3
-p_asyncRecord =
- (p_execAsyncOutput >>= return . ARExecAsyncOutput)
- <|> (p_statusAsyncOutput >>= return . ARStatusAsyncOutput)
- <|> (p_notifyAsyncOutput >>= return . ARNotifyAsyncOutput)
-
-p_execAsyncOutput :: Parser ExecAsyncOutput -- {{{3
-p_execAsyncOutput =
- ExecAsyncOutput <$> optionMaybe p_token <* char '*' <*> p_asyncOutput
-
-p_statusAsyncOutput :: Parser StatusAsyncOutput -- {{{3
-p_statusAsyncOutput =
- StatusAsyncOutput <$> optionMaybe p_token <* char '+' <*> p_asyncOutput
-
-p_notifyAsyncOutput :: Parser NotifyAsyncOutput -- {{{3
-p_notifyAsyncOutput =
- NotifyAsyncOutput <$> optionMaybe p_token <* char '=' <*> p_asyncOutput
-
-p_asyncOutput :: Parser AsyncOutput -- {{{3
-p_asyncOutput =
- AsyncOutput <$> p_asyncClass <*> many (char ',' >> p_result) <* newline
-
-p_resultClass :: Parser ResultClass -- {{{3
-p_resultClass =
- try (string "done" >> return RCDone)
- <|> try (string "running" >> return RCRunning)
- <|> try (string "connected" >> return RCConnected)
- <|> try (string "error" >> return RCError)
- <|> (string "exit" >> return RCExit)
-
-p_asyncClass :: Parser AsyncClass -- {{{3
-p_asyncClass =
- try (string "stopped" >> return ACStop)
- <|> try (string "thread-group-added" >> return ACThreadGroupAdded)
- <|> try (string "thread-group-started" >> return ACThreadGroupStarted)
- <|> try (string "thread-created" >> return ACThreadCreated)
- <|> try (string "running" >> return ACRunning)
- <|> try (string "thread-exited" >> return ACThreadExited)
- <|> try (string "thread-group-exited" >> return ACThreadGroupExited)
- <|> try (string "breakpoint-modified" >> return ACBreakpointModified)
- <|> (string "library-loaded" >> return ACLibraryLoaded)
-
-p_result :: Parser Result -- {{{3
-p_result =
- Result <$> p_variable <* char '=' <*> p_value
-
-p_variable :: Parser Variable -- {{{3
-p_variable = many1 (letter <|> digit <|> oneOf "_-")
-
-p_value :: Parser Value -- {{{3
-p_value =
- (p_const >>= return . VConst)
- <|> (p_tuple >>= return . VTuple)
- <|> (p_list >>= return . VList)
-
-p_const :: Parser Const -- {{{3
-p_const = p_cString
-
-p_tuple :: Parser Tuple -- {{{3
-p_tuple = try p_emptyTuple <|> p_filledTuple
- where
- p_emptyTuple = string "{}" >> return (Tuple [])
- p_filledTuple = do
- _ <- char '{'
- first <- p_result
- rest <- many (char ',' >> p_result)
- _ <- char '}'
- return $ Tuple (first:rest)
-
-p_list :: Parser List -- {{{3
-p_list = try p_emptyList <|> try p_valueList <|> p_resultList
- where
- p_emptyList = string "[]" >> return EmptyList
- p_valueList = do
- _ <- char '['
- first <- p_value
- rest <- many (char ',' >> p_value)
- _ <- char ']'
- return $ ValueList (first:rest)
-
- p_resultList = do
- _ <- char '['
- first <- p_result
- rest <- many (char ',' >> p_result)
- _ <- char ']'
- return $ ResultList (first:rest)
-
-p_streamRecord :: Parser StreamRecord -- {{{3
-p_streamRecord = do
- sr <- anyStreamRecord
- _ <- newline -- the documentation does not specifiy this newline, but this is what GDB is doing
- return sr
- where
- anyStreamRecord =
- (p_consoleStreamOutput >>= return . SRConsoleStreamOutput)
- <|> (p_targetStreamOutput >>= return . SRTargetStreamOutput)
- <|> (p_logStreamOutput >>= return . SRLogStreamOutput)
-
-p_consoleStreamOutput :: Parser ConsoleStreamOutput -- {{{3
-p_consoleStreamOutput = char '~' >> p_cString >>= return . ConsoleStreamOutput
-
-p_targetStreamOutput :: Parser TargetStreamOutput -- {{{3
-p_targetStreamOutput = char '@' >> p_cString >>= return . TargetStreamOutput
-
-p_logStreamOutput :: Parser LogStreamOutput -- {{{3
-p_logStreamOutput = char '&' >> p_cString >>= return . LogStreamOutput
-
-p_cString :: Parser CString -- {{{3
-p_cString = between (char '"') (char '"') (many p_cchar)
- where
- p_cchar = p_cbackslash
- <|> noneOf "\""
- p_cbackslash = do
- _ <- char '\\'
- c <- anyChar
- case c of
- '\\' -> return '\\'
- 'n' -> return '\n'
- '"' -> return '"'
- _ -> fail $ "unknown backslash escape: " ++ show c
-
-p_token :: Parser Token -- {{{3
-p_token = many1 digit >>= return . read
-
--- simplification {{{1
-data Response -- {{{2
- = Response {
- respClass :: ResultClass
- , respResults :: [Result]
- }
- deriving (Show)
-
-data Notification -- {{{2
- = Notification {
- notiClass :: NotificationClass
- , notiAsyncClass :: AsyncClass
- , notiResults :: [Result]
- }
- deriving Show
-
-data NotificationClass -- {{{3
- = Exec
- | Status
- | Notify
- deriving (Show, Eq)
-
-data Stream -- {{{2
- = Stream StreamClass String
- deriving Show
-
-data StreamClass -- {{{3
- = Console
- | Target
- | Log
- deriving Show
-
-output_response :: Output -> Maybe Response -- {{{2
-output_response (Output _ Nothing) = Nothing
-output_response (Output _ (Just (ResultRecord _ rc rs))) = Just $ Response rc rs
-
-output_notification :: Output -> [Notification] -- {{{2
-output_notification (Output oobs _) = map (notification . unp) $ filter isNotification oobs
- where
- isNotification (OOBAsyncRecord _) = True
- isNotification _ = False
-
- unp (OOBAsyncRecord x) = x
- unp x = error $ "unexpected parameter: " ++ show x
-
- notification (ARExecAsyncOutput (ExecAsyncOutput _ (AsyncOutput ac rs))) = Notification Exec ac rs
- notification (ARStatusAsyncOutput (StatusAsyncOutput _ (AsyncOutput ac rs))) = Notification Status ac rs
- notification (ARNotifyAsyncOutput (NotifyAsyncOutput _ (AsyncOutput ac rs))) = Notification Notify ac rs
-
-output_stream :: Output -> [Stream] -- {{{2
-output_stream (Output oobs _) = map (stream . unp) $ filter isStream oobs
- where
- isStream (OOBStreamRecord _) = True
- isStream _ = False
-
- unp (OOBStreamRecord x) = x
- unp x = error $ "unexpected parameter: " ++ show x
-
- stream (SRConsoleStreamOutput (ConsoleStreamOutput s)) = Stream Console s
- stream (SRTargetStreamOutput (TargetStreamOutput s)) = Stream Target s
- stream (SRLogStreamOutput (LogStreamOutput s)) = Stream Log s
-
--- utils {{{2
-asConst :: Value -> Maybe Const -- {{{2
-asConst (VConst x) = Just x
-asConst _ = Nothing
-
-asTuple :: Value -> Maybe Tuple -- {{{2
-asTuple (VTuple x) = Just x
-asTuple _ = Nothing
-
-asList :: Value -> Maybe List -- {{{2
-asList (VList x) = Just x
-asList _ = Nothing
-
--- token {{{1
-type Token = Int
-
-class GetToken a where
- get_token :: a -> Maybe Token
-
-instance GetToken ResultRecord where
- get_token (ResultRecord token _ _) = token
-
-instance GetToken Command where
- get_token (CLICommand token _) = token
- get_token (MICommand token _ _ _) = token
-
-instance GetToken Output where
- get_token (Output _ (Just r)) = get_token r
- get_token _ = Nothing
-
-instance GetToken OutOfBandRecord where
- get_token (OOBAsyncRecord r) = get_token r
- get_token (OOBStreamRecord _) = Nothing
-
-instance GetToken AsyncRecord where
- get_token (ARExecAsyncOutput x) = get_token x
- get_token (ARStatusAsyncOutput x) = get_token x
- get_token (ARNotifyAsyncOutput x) = get_token x
-
-instance GetToken ExecAsyncOutput where
- get_token (ExecAsyncOutput token _) = token
-
-instance GetToken StatusAsyncOutput where
- get_token (StatusAsyncOutput token _) = token
-
-instance GetToken NotifyAsyncOutput where
- get_token (NotifyAsyncOutput token _) = token
-
--- utils {{{1
-parameter_valid :: Parameter -> Bool -- {{{2
-parameter_valid (RawString s) = validParam s
-parameter_valid (QuotedString s) = validParam s
-
-validParam :: String -> Bool
-validParam param
- | null param = False
- | isCString param = isNothing $ find (not . isAscii) param
- | otherwise = isNothing $ find isSpecial param
- where
- isCString ('"':rest) = last rest == '"'
- isCString _ = False
-
- isSpecial ' ' = True
- isSpecial '-' = True
- isSpecial '\n' = True
- isSpecial '"' = True
- isSpecial _ = False
View
195 ruab/src/Ruab/Backend/GDB/Responses.hs
@@ -1,195 +0,0 @@
-module Ruab.Backend.GDB.Responses where
-
--- import {{{1
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad (guard, msum, (<=<))
-import Data.List (find)
-import Ruab.Backend.GDB.Representation
-
--- types {{{1
-type BkptNumber = Int
-data Breakpoint = Breakpoint { -- {{{2
- bkptNumber :: BkptNumber
- , bkptType :: BreakpointType
- , bkptDisp :: BreakpointDisp
- , bkptEnabled :: Bool
- , bkptAddress :: String
- , bkptFunc :: String
- , bkptFile :: String
- , bkptFullname :: String
- , bkptLine :: Int
- , bkptTimes :: Int
- , bkptOriginalLocation :: String
- }
- deriving Show
-
-type BreakpointType = String -- {{{2
-
-data BreakpointDisp -- {{{2
- = BreakpointKeep
- | BreakpointDel
- deriving Show
-
-instance Read BreakpointDisp where
- readsPrec _ "del" = [(BreakpointDel, "")]
- readsPrec _ "keep" = [(BreakpointKeep, "")]
- readsPrec _ _ = []
-
-newtype Stack -- {{{2
- = Stack {stackFrames :: [Frame] }
- deriving Show
-
-data Frame = Frame { -- {{{2
- frameLevel :: Maybe Int
- , frameAddr :: String
- , frameFunc :: String
- , frameArgs :: Maybe [Arg]
- , frameFile :: String
- , frameFullname :: Maybe String
- , frameLine :: Int
- } deriving Show
-
-data Stopped = Stopped { -- {{{2
- stoppedReason :: StopReason
- , stoppedFrame :: Frame
- , stoppedThreadId :: Int
- , stoppedThreads :: String
- , stoppedCore :: Int
- }
- deriving Show
-
-data StopReason -- {{{2
- = BreakpointHit {
- bkptHitDisp :: BreakpointDisp
- , bkptHitNumber :: BkptNumber
- }
- | EndSteppingRange
- | FunctionFinished
-
- deriving Show
-
-data Arg = Arg { -- {{{2
- argName :: String
- , argValue :: String
- } deriving Show
-
--- composition {{{1
-responseBreakpoint :: Result -> Maybe Breakpoint -- {{{2
-responseBreakpoint (Result variable value) = do
- guard (variable == "bkpt")
- (Tuple rs) <- asTuple value
- Breakpoint
- <$> get rs tryRead "number"
- <*> get rs Just "type"
- <*> get rs tryRead "disp"
- <*> get rs gdbBool "enabled"
- <*> get rs Just "addr"
- <*> get rs Just "func"
- <*> get rs Just "file"
- <*> get rs Just "fullname"
- <*> get rs tryRead "line"
- <*> get rs tryRead "times"
- <*> get rs Just "original-location"
-
-responseStack :: Result -> Maybe Stack -- {{{2
-responseStack (Result variable value) = do
- guard (variable == "stack")
- list <- asList value
- case list of
- EmptyList -> Just $ Stack []
- ResultList is ->
- Stack <$> mapM responseFrame is
- _ -> Nothing
-
-responseFrame :: Result -> Maybe Frame -- {{{2
-responseFrame (Result variable value) = do
- guard (variable == "frame")
- (Tuple rs) <- asTuple value
- Frame
- <$> Just (get rs tryRead "level")
- <*> get rs Just "addr"
- <*> get rs Just "func"
- <*> Just (msum (map responseArgs rs))
- <*> get rs Just "file"
- <*> Just (get rs Just "fullname")
- <*> get rs tryRead "line"
-
-responseStopped :: [Result] -> Maybe Stopped -- {{{2
-responseStopped rs = do
- Stopped
- <$> responseStopReason rs
- <*> msum (map responseFrame rs)
- <*> get rs tryRead "thread-id"
- <*> get rs Just "stopped-threads"
- <*> get rs tryRead "core"
-
-responseStopReason :: [Result] -> Maybe StopReason -- {{{2
-responseStopReason rs = do
- reason <- find (("reason"==) . resVariable) rs >>= asConst . resValue
- case reason of
- "breakpoint-hit" ->
- BreakpointHit
- <$> get rs tryRead "disp"
- <*> get rs tryRead "bkptno"
- "end-stepping-range" -> Just EndSteppingRange
- "function-finished" -> Just FunctionFinished
- _ -> Nothing
-
-responseArgs :: Result -> Maybe [Arg] -- {{{2
-responseArgs (Result variable value) = do
- guard (variable == "args")
- list <- asList value
- case list of
- EmptyList -> Just []
- ValueList is -> do
- mapM ((responseArg . tupleResults) <=< asTuple) is
- _ -> Nothing
-
-responseArg :: [Result] -> Maybe Arg -- {{{2
-responseArg rs = do
- Arg
- <$> get rs Just "name"
- <*> get rs Just "value"
-
--- responses {{{1
-response_stack_list_frames :: [Result] -> Maybe Stack -- {{{2
-response_stack_list_frames [item] = responseStack item
-response_stack_list_frames _ = Nothing
-
-response_break_insert :: [Result] -> Maybe Breakpoint -- {{{2
-response_break_insert [item] = responseBreakpoint item
-response_break_insert _ = Nothing
-
-response_data_evaluate_expression :: [Result] -> Maybe String -- {{{2
-response_data_evaluate_expression [(Result variable value)] = do
- guard (variable == "value")
- asConst value
-
-response_data_evaluate_expression _ = Nothing -- {{{2
-
-response_error :: [Result] -> Maybe String -- {{{2
-response_error [(Result variable value)] = do
- guard (variable == "msg")
- asConst value
-response_error _ = Nothing
-
-response_stopped :: [Result] -> Maybe Stopped -- {{{2
-response_stopped items = responseStopped items
-
-response_exec_return :: [Result] -> Maybe Frame -- {{{2
-response_exec_return [item] = responseFrame item
-response_exec_return _ = Nothing
-
--- utils {{{1
-get :: [Result] -> (String -> Maybe a) -> (String -> Maybe a) -- {{{2
-get rs parse key = find ((key==) . resVariable) rs >>= asConst . resValue >>= parse
-
-tryRead :: Read a => String -> Maybe a -- {{{2
-tryRead str = case readsPrec 0 str of
- [(x, "")] -> Just x
- _ -> Nothing
-
-gdbBool :: String -> Maybe Bool -- {{{2
-gdbBool "y" = Just True
-gdbBool "n" = Just False
-gdbBool _ = Nothing
View
340 ruab/src/Ruab/Backend/GDB/Test.hs
@@ -1,340 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-module Ruab.Backend.GDB.Test (tests) where
-
--- imports {{{1
-import Ruab.Backend.GDB.Representation
-import Ruab.Backend.GDB.Responses
-import Ruab.Test.Lib (enumTestGroup, paste)
-import Test.Framework (Test, testGroup)
-import Test.HUnit ((@=?), Assertion)
-
-tests :: Test -- {{{1
-tests = testGroup "GDB" [
- test_render_command
- , test_parse_output
- , test_response_break_insert
- , test_response_stopped
- , test_response_stack_list_frames
- , test_response_exec_return
- , test_response_evaluate_expression
- , test_response_error
- ]
-
-test_render_command:: Test -- {{{2
-test_render_command = enumTestGroup "render_command" $ map runTest [
- (
- MICommand Nothing "break-info" [] []
- , "-break-info\n"
- ), (
- MICommand (Just 23) "exec-arguments" [Option (qp "-v") (Just (qp "word"))] []
- , "23-exec-arguments \"-v\" \"word\"\n"
- ), (
- MICommand (Just 42) "break-commands" [Option (qp "1") Nothing, Option (qp "print v") Nothing] []
- , "42-break-commands \"1\" \"print v\"\n"
- )
- ]
- where
- runTest :: (Command, String) -> Assertion
- runTest (cmd, expected) = expected @=? render_command cmd
-
-test_parse_output :: Test -- {{{2
-test_parse_output = enumTestGroup "parse_output" $ map runTest [
- -- welcome text {{{3
- ([paste|
-=thread-group-added,id="i1"
-~"GNU gdb (GDB) 7.2-ubuntu\n"
-~"Copyright (C) 2010 Free Software Foundation, Inc.\n"
-~"License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>\nThis is free software: you are free to change and redistribute it.\nThere is NO WARRANTY, to the extent permitted by law. Type \"show copying\"\nand \"show warranty\" for details.\n"
-~"This GDB was configured as \"x86_64-linux-gnu\".\nFor bug reporting instructions, please see:\n"
-~"<http://www.gnu.org/software/gdb/bugs/>...\n"
-~"Reading symbols from /home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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 /home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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="/home/alex/scm/ocram/applications/simulation_os/os/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 "/home/alex/scm/ocram/applications/simulation_os/os/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="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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 "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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" "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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 "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c",line="196"},thread-id="1",stopped-threads="all",core="1"
-(gdb)
-|], Stopped EndSteppingRange (Frame Nothing "0x00000000004017fa" "main" (Just []) "pal.c" (Just "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c") 196) 1 "all" 1)
- ]
- where
- runTest :: (String, Stopped) -> Assertion -- {{{3
- runTest (str, stp) =
- let
- output = parse_output (tail str)
- [notification] = output_notification output
- stp' = response_stopped (notiResults notification)
- in
- show (Just stp) @=? show stp'
-
-test_response_stack_list_frames :: Test -- {{{2
-test_response_stack_list_frames = enumTestGroup "response_stack_list_frames" $ map runTest [
- -- example {{{3
- ([paste|
-^done,stack=[frame={level="0",addr="0x00007ffff7a9dcc7",func="_IO_vfprintf_internal",file="vfprintf.c",line="1647"},frame={level="1",addr="0x00007ffff7ac2c79",func="__IO_vsprintf",file="iovsprintf.c",line="43"},frame={level="2",addr="0x0000000000402520",func="logger_syscall",file="logger.c",fullname="/home/alex/scm/ocram/applications/simulation_os/os/logger.c",line="57"},frame={level="3",addr="0x0000000000401c13",func="os_receive",file="core.c",fullname="/home/alex/scm/ocram/applications/simulation_os/os/core.c",line="145"},frame={level="4",addr="0x0000000000401489",func="tc_receive",file="pal.c",fullname="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c",line="116"},frame={level="5",addr="0x0000000000400e2e",func="ec_thread_1",file="ec.c",fullname="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/ec.c",line="433"},frame={level="6",addr="0x00000000004016b2",func="flash_write_cb",file="pal.c",fullname="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c",line="156"},frame={level="7",addr="0x00000000004019ff",func="cb_default",file="core.c",fullname="/home/alex/scm/ocram/applications/simulation_os/os/core.c",line="90"},frame={level="8",addr="0x0000000000402f05",func="dispatcher_run",file="dispatcher.c",fullname="/home/alex/scm/ocram/applications/simulation_os/os/dispatcher.c",line="93"},frame={level="9",addr="0x000000000040188e",func="os_run",file="core.c",fullname="/home/alex/scm/ocram/applications/simulation_os/os/core.c",line="37"},frame={level="10",addr="0x00000000004012f0",func="pal_run",file="pal.c",fullname="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c",line="70"},frame={level="11",addr="0x0000000000401818",func="main",file="pal.c",fullname="/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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 "/home/alex/scm/ocram/applications/simulation_os/os/logger.c") 57
- , Frame (Just 3) "0x0000000000401c13" "os_receive" Nothing "core.c" (Just "/home/alex/scm/ocram/applications/simulation_os/os/core.c") 145
- , Frame (Just 4) "0x0000000000401489" "tc_receive" Nothing "pal.c" (Just "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c") 116
- , Frame (Just 5) "0x0000000000400e2e" "ec_thread_1" Nothing "ec.c" (Just "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/ec.c") 433
- , Frame (Just 6) "0x00000000004016b2" "flash_write_cb" Nothing "pal.c" (Just "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c") 156
- , Frame (Just 7) "0x00000000004019ff" "cb_default" Nothing "core.c" (Just "/home/alex/scm/ocram/applications/simulation_os/os/core.c") 90
- , Frame (Just 8) "0x0000000000402f05" "dispatcher_run" Nothing "dispatcher.c" (Just "/home/alex/scm/ocram/applications/simulation_os/os/dispatcher.c") 93
- , Frame (Just 9) "0x000000000040188e" "os_run" Nothing "core.c" (Just "/home/alex/scm/ocram/applications/simulation_os/os/core.c") 37
- , Frame (Just 10) "0x00000000004012f0" "pal_run" Nothing "pal.c" (Just "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/pal.c") 70
- , Frame (Just 11) "0x0000000000401818" "main" Nothing "pal.c" (Just "/home/alex/scm/ocram/applications/simulation_os/collect-and-forward/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="/home/alex/foo.c",line="9"}
-(gdb)
-|], Frame (Just 0) "0x080483cc" "f" (Just []) "foo.c" (Just "/home/alex/foo.c") 9
- )
- ]
- where
- runTest :: (String, Frame) -> Assertion -- {{{3
- runTest (str, frame) =
- let
- output = parse_output (tail str)
- frame' = do
- response <- output_response output
- response_exec_return (respResults response)
- in
- show (Just frame) @=? show frame'
-
-test_response_evaluate_expression :: Test -- {{{2
-test_response_evaluate_expression = enumTestGroup "response_evaluate_expression" $ map runTest [
- -- example {{{3
- ([paste|
-^done,value="24"
-(gdb)
-|], "24")
- ]
- where
- runTest :: (String, String) -> Assertion -- {{{3
- runTest (str, expr) =
- let
- output = parse_output (tail str)
- (Just response) = output_response output
- in do
- RCDone @=? respClass response
- Just expr @=? (response_data_evaluate_expression . respResults) response
-
-test_response_error :: Test -- {{{2
-test_response_error = enumTestGroup "response_error" $ map runTest [
- -- example {{{3
- ([paste|
-^error,msg="No symbol \"j\" in current context."
-(gdb)
-|], "No symbol \"j\" in current context.")
- ]
- where
- runTest :: (String, String) -> Assertion -- {{{3
- runTest (str, err) =
- let
- output = parse_output (tail str)
- (Just response) = output_response output
- in do
- RCError @=? respClass response
- Just err @=? (response_error . respResults) response
-
--- utils {{{1
-qp :: String -> Parameter
-qp = QuotedString
View
7 ruab/src/Ruab/Backend/Test.hs
@@ -1,7 +0,0 @@
-module Ruab.Backend.Test (tests) where
-
-import Test.Framework (Test, testGroup)
-import qualified Ruab.Backend.GDB.Test as A
-
-tests :: Test
-tests = testGroup "Backend" [A.tests]
View
5 ruab/src/Ruab/Core.hs
@@ -159,7 +159,10 @@ create_network ctx opt fResponse fStatus = do
when (not (stateHide state') && status /= status') (fStatus status')
return state'
- backend <- mfix (\backend' -> B.setup opt (B.Callback display (fCore . handleStop ctx backend') display))
+ backend <- mfix (\backend' ->
+ let stoppedHandler = fCore . handleStop ctx backend' in
+ B.setup opt (B.Callback display display (Just (mapM_ stoppedHandler)))
+ )
fStatus (state2status s0)
fCore (setupBreakpoints ctx backend)
View
5 ruab/src/Ruab/Test.hs
@@ -4,11 +4,10 @@ module Ruab.Test (runTests) where
import Test.Framework (Test, testGroup, defaultMainWithArgs)
import qualified Ruab.Frontend.Test as A
-import qualified Ruab.Backend.Test as B
-import qualified Ruab.Core.Test as C
+import qualified Ruab.Core.Test as B
runTests :: [String] -> IO () -- {{{1
runTests = defaultMainWithArgs [tests]
tests :: Test -- {{{2
-tests = testGroup "Ruab" [A.tests, B.tests, C.tests]
+tests = testGroup "Ruab" [A.tests, B.tests]

0 comments on commit c7166ea

Please sign in to comment.