Sketch out debug GUI.
This commit is contained in:
parent
c946b5ed8a
commit
4f540b1469
|
@ -0,0 +1,49 @@
|
||||||
|
#lang marketplace
|
||||||
|
|
||||||
|
(require "../support/debug.rkt")
|
||||||
|
|
||||||
|
(debug
|
||||||
|
(nested-vm
|
||||||
|
#:debug-name 'echo
|
||||||
|
(at-meta-level
|
||||||
|
(endpoint
|
||||||
|
#:subscriber (tcp-channel ? (tcp-listener 5999) ?)
|
||||||
|
#:observer
|
||||||
|
#:conversation (tcp-channel them us _)
|
||||||
|
#:on-presence
|
||||||
|
(debug
|
||||||
|
(spawn #:debug-name (list 'session them)
|
||||||
|
#:child (chat-session them us)))))))
|
||||||
|
|
||||||
|
(define (chat-session them us)
|
||||||
|
(define user (gensym 'user))
|
||||||
|
(transition stateless
|
||||||
|
(listen-to-user user them us)
|
||||||
|
(speak-to-user user them us)))
|
||||||
|
|
||||||
|
(define (listen-to-user user them us)
|
||||||
|
(list
|
||||||
|
(endpoint #:publisher `(,user says ,?))
|
||||||
|
(at-meta-level
|
||||||
|
(endpoint #:subscriber (tcp-channel them us ?)
|
||||||
|
#:on-absence (quit)
|
||||||
|
[(tcp-channel _ _ (? bytes? text))
|
||||||
|
(send-message `(,user says ,text))]))))
|
||||||
|
|
||||||
|
(define (speak-to-user user them us)
|
||||||
|
(define (say fmt . args)
|
||||||
|
(at-meta-level
|
||||||
|
(send-message
|
||||||
|
(tcp-channel us them (apply format fmt args)))))
|
||||||
|
(define (announce who did-what)
|
||||||
|
(unless (equal? who user)
|
||||||
|
(say "~s ~s.~n" who did-what)))
|
||||||
|
(list
|
||||||
|
(say "You are ~s.~n" user)
|
||||||
|
(at-meta-level
|
||||||
|
(endpoint #:publisher (tcp-channel us them ?)))
|
||||||
|
(endpoint #:subscriber `(,? says ,?)
|
||||||
|
#:conversation `(,who says ,_)
|
||||||
|
#:on-presence (announce who 'arrived)
|
||||||
|
#:on-absence (announce who 'departed)
|
||||||
|
[`(,who says ,what) (say "~a: ~a" who what)])))
|
|
@ -8,8 +8,14 @@
|
||||||
(require "../process.rkt")
|
(require "../process.rkt")
|
||||||
(require "../quasiqueue.rkt")
|
(require "../quasiqueue.rkt")
|
||||||
|
|
||||||
|
(require/typed "gui.rkt"
|
||||||
|
[opaque AnyState any-state?]
|
||||||
|
[open-debugger (Any -> (Values (AnyState -> Void) (-> Void)))])
|
||||||
|
|
||||||
(provide debug)
|
(provide debug)
|
||||||
|
|
||||||
|
(struct: debugger ([out : (AnyState -> Void)] [in : (-> Void)]))
|
||||||
|
|
||||||
(: debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState)))
|
(: debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState)))
|
||||||
(define (debug spawn-child)
|
(define (debug spawn-child)
|
||||||
(match-define (core:spawn child-spec parent-k debug-name) spawn-child)
|
(match-define (core:spawn child-spec parent-k debug-name) spawn-child)
|
||||||
|
@ -21,18 +27,25 @@
|
||||||
(define (wrapped-cotransition k)
|
(define (wrapped-cotransition k)
|
||||||
(: receiver : (All (S) (Transition S) -> R))
|
(: receiver : (All (S) (Transition S) -> R))
|
||||||
(define (receiver child-transition)
|
(define (receiver child-transition)
|
||||||
((inst k S) (wrap-transition debug-name child-transition)))
|
(define-values (send-to-debugger! receive-from-debugger!)
|
||||||
|
(open-debugger debug-name))
|
||||||
|
(define d (debugger send-to-debugger! receive-from-debugger!))
|
||||||
|
((inst k S) (wrap-transition d child-transition)))
|
||||||
((inst original-cotransition R) receiver))
|
((inst original-cotransition R) receiver))
|
||||||
wrapped-cotransition))
|
wrapped-cotransition))
|
||||||
parent-k
|
parent-k
|
||||||
(list 'debug debug-name)))
|
(list 'debug debug-name)))
|
||||||
|
|
||||||
(: wrap-transition : (All (ChildState) Any (Transition ChildState) -> (Transition ChildState)))
|
(: wrap-transition : (All (ChildState)
|
||||||
(define (wrap-transition debug-name child-transition)
|
debugger
|
||||||
|
(Transition ChildState)
|
||||||
|
-> (Transition ChildState)))
|
||||||
|
(define (wrap-transition d child-transition)
|
||||||
|
((debugger-out d) (cast child-transition AnyState))
|
||||||
|
((debugger-in d))
|
||||||
(match-define (core:transition child-state child-actions) child-transition)
|
(match-define (core:transition child-state child-actions) child-transition)
|
||||||
(log-debug "~v: New State ~v" debug-name child-state)
|
|
||||||
(core:transition child-state ((inst action-tree-map ChildState)
|
(core:transition child-state ((inst action-tree-map ChildState)
|
||||||
(wrap-action debug-name)
|
(wrap-action d)
|
||||||
child-actions)))
|
child-actions)))
|
||||||
|
|
||||||
(: action-tree-map : (All (State) ((Action State) -> (Action State))
|
(: action-tree-map : (All (State) ((Action State) -> (Action State))
|
||||||
|
@ -43,53 +56,58 @@
|
||||||
f
|
f
|
||||||
(quasiqueue->list (action-tree->quasiqueue actions))))
|
(quasiqueue->list (action-tree->quasiqueue actions))))
|
||||||
|
|
||||||
(: wrap-action : (All (ChildState) Any -> ((Action ChildState) -> (Action ChildState))))
|
(: wrap-action : (All (ChildState)
|
||||||
(define ((wrap-action debug-name) action)
|
debugger
|
||||||
|
-> ((Action ChildState) -> (Action ChildState))))
|
||||||
|
(define ((wrap-action d) action)
|
||||||
(cond
|
(cond
|
||||||
[(core:yield? action)
|
[(core:yield? action)
|
||||||
(log-debug "~v: Yield" debug-name)
|
(core:yield (wrap-interruptk d (core:yield-k action)))]
|
||||||
(core:yield (wrap-interruptk debug-name (core:yield-k action)))]
|
|
||||||
[(core:at-meta-level? action)
|
[(core:at-meta-level? action)
|
||||||
(core:at-meta-level (wrap-preaction "Outer" debug-name (core:at-meta-level-preaction action)))]
|
(core:at-meta-level (wrap-preaction #t d (core:at-meta-level-preaction action)))]
|
||||||
[else
|
[else
|
||||||
(wrap-preaction "Inner" debug-name action)]))
|
(wrap-preaction #f d action)]))
|
||||||
|
|
||||||
(: wrap-preaction : (All (ChildState) String Any (PreAction ChildState) -> (PreAction ChildState)))
|
(: wrap-preaction : (All (ChildState)
|
||||||
(define (wrap-preaction level debug-name preaction)
|
Boolean
|
||||||
|
debugger
|
||||||
|
(PreAction ChildState)
|
||||||
|
-> (PreAction ChildState)))
|
||||||
|
(define (wrap-preaction meta? d preaction)
|
||||||
(match preaction
|
(match preaction
|
||||||
[(core:add-endpoint pre-eid role handler)
|
[(core:add-endpoint pre-eid role handler)
|
||||||
(log-debug "~v: ~a AddEndpoint ~v ~v" debug-name level pre-eid role)
|
(core:add-endpoint pre-eid role (wrap-handler meta? d handler))]
|
||||||
(core:add-endpoint pre-eid role (wrap-handler debug-name handler))]
|
|
||||||
[(core:delete-endpoint pre-eid reason)
|
[(core:delete-endpoint pre-eid reason)
|
||||||
(log-debug "~v: ~a DeleteEndpoint ~v ~v" debug-name level pre-eid reason)
|
|
||||||
preaction]
|
preaction]
|
||||||
[(core:send-message body orientation)
|
[(core:send-message body orientation)
|
||||||
(log-debug "~v: ~a SendMessage ~v ~v" debug-name level body orientation)
|
|
||||||
preaction]
|
preaction]
|
||||||
[(core:spawn spec maybe-k child-debug-name)
|
[(core:spawn spec maybe-k child-debug-name)
|
||||||
(log-debug "~v: ~a Spawn ~v" debug-name level child-debug-name)
|
(core:spawn spec (wrap-spawnk d maybe-k) child-debug-name)]
|
||||||
(core:spawn spec (wrap-spawnk debug-name maybe-k) child-debug-name)]
|
|
||||||
[(core:quit pid reason)
|
[(core:quit pid reason)
|
||||||
(log-debug "~v: ~a Quit ~v ~v" debug-name level pid reason)
|
|
||||||
preaction]))
|
preaction]))
|
||||||
|
|
||||||
(: wrap-interruptk : (All (ChildState) Any (InterruptK ChildState) -> (InterruptK ChildState)))
|
(: wrap-interruptk : (All (ChildState)
|
||||||
(define (wrap-interruptk debug-name ik)
|
debugger
|
||||||
|
(InterruptK ChildState)
|
||||||
|
-> (InterruptK ChildState)))
|
||||||
|
(define (wrap-interruptk d ik)
|
||||||
(lambda (state)
|
(lambda (state)
|
||||||
(log-debug "~v: Old State ~v" debug-name state)
|
(wrap-transition d (ik state))))
|
||||||
(wrap-transition debug-name (ik state))))
|
|
||||||
|
|
||||||
(: wrap-spawnk : (All (ChildState)
|
(: wrap-spawnk : (All (ChildState)
|
||||||
Any
|
debugger
|
||||||
(Option (PID -> (InterruptK ChildState)))
|
(Option (PID -> (InterruptK ChildState)))
|
||||||
-> (Option (PID -> (InterruptK ChildState)))))
|
-> (Option (PID -> (InterruptK ChildState)))))
|
||||||
(define (wrap-spawnk debug-name maybe-k)
|
(define (wrap-spawnk d maybe-k)
|
||||||
(and maybe-k
|
(and maybe-k
|
||||||
(lambda: ([child-pid : PID]) (wrap-interruptk debug-name (maybe-k child-pid)))))
|
(lambda: ([child-pid : PID]) (wrap-interruptk d (maybe-k child-pid)))))
|
||||||
|
|
||||||
(: wrap-handler : (All (ChildState) Any (Handler ChildState) -> (Handler ChildState)))
|
(: wrap-handler : (All (ChildState)
|
||||||
(define (wrap-handler debug-name h)
|
Boolean
|
||||||
|
debugger
|
||||||
|
(Handler ChildState)
|
||||||
|
-> (Handler ChildState)))
|
||||||
|
(define (wrap-handler meta? d h)
|
||||||
(lambda (event)
|
(lambda (event)
|
||||||
(log-debug "~v: Incoming Event ~v" debug-name event)
|
((debugger-out d) (cast (cons meta? event) AnyState))
|
||||||
(wrap-interruptk debug-name (h event))))
|
(wrap-interruptk d (h event))))
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,267 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require racket/set)
|
||||||
|
(require racket/match)
|
||||||
|
(require racket/class)
|
||||||
|
(require racket/async-channel)
|
||||||
|
(require racket/gui/base)
|
||||||
|
(require racket/date)
|
||||||
|
(require racket/format)
|
||||||
|
(require racket/math)
|
||||||
|
|
||||||
|
(require images/icons/control)
|
||||||
|
(require images/icons/arrow)
|
||||||
|
(require images/icons/symbol)
|
||||||
|
(require images/icons/misc)
|
||||||
|
(require images/icons/style)
|
||||||
|
|
||||||
|
(require racket/pretty)
|
||||||
|
|
||||||
|
(require (prefix-in core: "../types.rkt"))
|
||||||
|
|
||||||
|
(provide any-state?
|
||||||
|
open-debugger)
|
||||||
|
|
||||||
|
;; Frame
|
||||||
|
;; Toolbar
|
||||||
|
;; Rewind one step - moves without executing
|
||||||
|
;; Fast-forward one step - moves without executing
|
||||||
|
;; --
|
||||||
|
;; Stop
|
||||||
|
;; Run one step
|
||||||
|
;; Play
|
||||||
|
;; --
|
||||||
|
;; Select history depth
|
||||||
|
;; --
|
||||||
|
;; Kill this process
|
||||||
|
;; State display
|
||||||
|
;; If the state is (vm?), special display; permits spawning debuggers on nested processes
|
||||||
|
;; Endpoints display
|
||||||
|
;; Shows ID and role
|
||||||
|
;; Permits deletion of endpoint
|
||||||
|
;; Permits interaction with endpoint??
|
||||||
|
;; Trace display
|
||||||
|
;; Selection of a row rewinds to that point
|
||||||
|
|
||||||
|
(define (any-state? x) #t)
|
||||||
|
|
||||||
|
(define (open-debugger name)
|
||||||
|
(define to-debugger (make-channel))
|
||||||
|
(define from-debugger (make-semaphore 0))
|
||||||
|
(parameterize ((current-eventspace (make-eventspace)))
|
||||||
|
(new debugger%
|
||||||
|
[name name]
|
||||||
|
[from-vm to-debugger]
|
||||||
|
[to-vm from-debugger]))
|
||||||
|
(values (lambda (t) (channel-put to-debugger t))
|
||||||
|
(lambda () (semaphore-wait from-debugger))))
|
||||||
|
|
||||||
|
(define debugger%
|
||||||
|
(class object%
|
||||||
|
|
||||||
|
(init-field name)
|
||||||
|
(init-field from-vm)
|
||||||
|
(init-field to-vm)
|
||||||
|
|
||||||
|
(define mutex (make-semaphore 1))
|
||||||
|
(define stepping? #t)
|
||||||
|
(define waiting? #f)
|
||||||
|
|
||||||
|
(define frame (new frame%
|
||||||
|
[label (format "~a" name)]
|
||||||
|
[width 480]
|
||||||
|
[height 700]))
|
||||||
|
|
||||||
|
(define menu-bar (new menu-bar% [parent frame]))
|
||||||
|
(define edit-menu (new menu% [label "Edit"] [parent menu-bar]))
|
||||||
|
(append-editor-operation-menu-items edit-menu #f)
|
||||||
|
|
||||||
|
(define toolbar (new horizontal-pane%
|
||||||
|
[parent frame]
|
||||||
|
[stretchable-height #f]
|
||||||
|
[alignment '(right center)]))
|
||||||
|
|
||||||
|
(define state-panel (new horizontal-panel%
|
||||||
|
[parent frame]))
|
||||||
|
|
||||||
|
(define endpoints (new list-box%
|
||||||
|
[style '(single column-headers)]
|
||||||
|
[label #f]
|
||||||
|
[choices '()]
|
||||||
|
[parent frame]
|
||||||
|
[columns '("ID" "Orientation" "Topic" "Type")]))
|
||||||
|
|
||||||
|
(define events (new list-box%
|
||||||
|
[style '(single column-headers)]
|
||||||
|
[label #f]
|
||||||
|
[choices '()]
|
||||||
|
[parent frame]
|
||||||
|
[columns '("Time" "Dir" "Type" "Detail")]))
|
||||||
|
|
||||||
|
(send endpoints set-column-width 1 32 32 32)
|
||||||
|
(send endpoints set-column-width 3 32 32 32)
|
||||||
|
|
||||||
|
(send events set-column-width 1 32 32 32)
|
||||||
|
|
||||||
|
(define (toolbar-button label [handler void])
|
||||||
|
(new button%
|
||||||
|
[label label]
|
||||||
|
[min-width 32]
|
||||||
|
[parent toolbar]
|
||||||
|
[callback handler]))
|
||||||
|
|
||||||
|
(define (toolbar-spacer)
|
||||||
|
(new pane% [parent toolbar] [min-width 16] [stretchable-width #f]))
|
||||||
|
|
||||||
|
;; (toolbar-button (left-over-arrow-icon #:color syntax-icon-color))
|
||||||
|
;; (toolbar-button (right-over-arrow-icon #:color syntax-icon-color))
|
||||||
|
;; (toolbar-spacer)
|
||||||
|
|
||||||
|
(define pause-button
|
||||||
|
(toolbar-button (pause-icon #:color halt-icon-color)
|
||||||
|
(lambda (b e)
|
||||||
|
(send pause-button enable #f)
|
||||||
|
(send play-button enable #t)
|
||||||
|
(send step-button enable #t)
|
||||||
|
(call-with-semaphore
|
||||||
|
mutex
|
||||||
|
(lambda ()
|
||||||
|
(set! stepping? #f))))))
|
||||||
|
(define play-button
|
||||||
|
(toolbar-button (play-icon #:color run-icon-color)
|
||||||
|
(lambda (b e)
|
||||||
|
(send pause-button enable #t)
|
||||||
|
(send play-button enable #f)
|
||||||
|
(send step-button enable #f)
|
||||||
|
(call-with-semaphore
|
||||||
|
mutex
|
||||||
|
(lambda ()
|
||||||
|
(set! stepping? #t)
|
||||||
|
(when waiting?
|
||||||
|
(set! waiting? #f)
|
||||||
|
(semaphore-post to-vm)))))))
|
||||||
|
(toolbar-spacer)
|
||||||
|
(define step-button
|
||||||
|
(toolbar-button (step-icon #:color run-icon-color)
|
||||||
|
(lambda (b e)
|
||||||
|
(call-with-semaphore
|
||||||
|
mutex
|
||||||
|
(lambda ()
|
||||||
|
(when waiting?
|
||||||
|
(set! waiting? #f)
|
||||||
|
(semaphore-post to-vm)))))))
|
||||||
|
|
||||||
|
(send play-button enable #f)
|
||||||
|
(send step-button enable #f)
|
||||||
|
|
||||||
|
;; (toolbar-spacer)
|
||||||
|
;; (toolbar-button "Settings...")
|
||||||
|
;; (toolbar-spacer)
|
||||||
|
;; (toolbar-button (stop-sign-icon))
|
||||||
|
|
||||||
|
(define state-text (new text%))
|
||||||
|
(define state-canvas (new editor-canvas%
|
||||||
|
[parent state-panel]
|
||||||
|
[editor state-text]
|
||||||
|
[label "State"]))
|
||||||
|
|
||||||
|
(define controller-thread
|
||||||
|
(thread
|
||||||
|
(lambda ()
|
||||||
|
(controller-thread-loop))))
|
||||||
|
|
||||||
|
(define (current-timestamp)
|
||||||
|
(define (p n w) (~a (exact-truncate n) #:width w #:align 'right #:pad-string "0"))
|
||||||
|
(define d (current-date))
|
||||||
|
(format "~a:~a:~a.~a ~a-~a-~a"
|
||||||
|
(p (date-hour d) 2)
|
||||||
|
(p (date-minute d) 2)
|
||||||
|
(p (date-second d) 2)
|
||||||
|
(p (/ (date*-nanosecond d) 1000000.0) 3)
|
||||||
|
(date-year d)
|
||||||
|
(p (date-month d) 2)
|
||||||
|
(p (date-day d) 2)))
|
||||||
|
|
||||||
|
(define (record-event! stamp dir type detail)
|
||||||
|
(define n (send events get-number))
|
||||||
|
(send events append stamp)
|
||||||
|
(send events set-string n dir 1)
|
||||||
|
(send events set-string n type 2)
|
||||||
|
(send events set-string n (~a detail) 3)
|
||||||
|
(send events set-first-visible-item
|
||||||
|
(max 0 (- n (- (send events number-of-visible-items) 1)))))
|
||||||
|
|
||||||
|
(define (format-action action)
|
||||||
|
(cond
|
||||||
|
[(core:yield? action)
|
||||||
|
(values "Yield" "")]
|
||||||
|
[(core:at-meta-level? action)
|
||||||
|
(format-preaction "Meta" (core:at-meta-level-preaction action))]
|
||||||
|
[else
|
||||||
|
(format-preaction "" action)]))
|
||||||
|
|
||||||
|
(define (format-preaction layer preaction)
|
||||||
|
(define-values (type detail)
|
||||||
|
(match preaction
|
||||||
|
[(core:add-endpoint pre-eid role handler)
|
||||||
|
(values "Sub" (string-append (format-role role) " " (~a pre-eid)))]
|
||||||
|
[(core:delete-endpoint pre-eid reason)
|
||||||
|
(values "Unsub" (format "~a ~v" pre-eid reason))]
|
||||||
|
[(core:send-message body 'publisher)
|
||||||
|
(values "Send" (~v body))]
|
||||||
|
[(core:send-message body 'subscriber)
|
||||||
|
(values "Feedback" (~v body))]
|
||||||
|
[(core:spawn spec maybe-k child-debug-name)
|
||||||
|
(values "Spawn" (~v child-debug-name))]
|
||||||
|
[(core:quit #f reason)
|
||||||
|
(values "Exit" (~v reason))]
|
||||||
|
[(core:quit pid reason)
|
||||||
|
(values "Kill" (format "~a ~v" pid reason))]))
|
||||||
|
(values (string-append layer type) detail))
|
||||||
|
|
||||||
|
(define (format-role r)
|
||||||
|
(match-define (core:role orientation topic interest-type) r)
|
||||||
|
(format "~a/~a ~v"
|
||||||
|
(string-ref (symbol->string orientation) 0)
|
||||||
|
(string-ref (symbol->string interest-type) 0)
|
||||||
|
topic))
|
||||||
|
|
||||||
|
(define (handle-from-vm x)
|
||||||
|
(define now (current-timestamp))
|
||||||
|
(match x
|
||||||
|
[(core:transition state actions)
|
||||||
|
(send state-text erase)
|
||||||
|
(send state-text insert (pretty-format state))
|
||||||
|
(let loop ((a actions))
|
||||||
|
(cond
|
||||||
|
[(pair? a) (loop (car a)) (loop (cdr a))]
|
||||||
|
[(or (null? a) (eq? a #f) (void? a)) (void)]
|
||||||
|
[else (define-values (type detail) (format-action a))
|
||||||
|
(record-event! now "Act" type detail)]))
|
||||||
|
(call-with-semaphore
|
||||||
|
mutex
|
||||||
|
(lambda ()
|
||||||
|
(if stepping?
|
||||||
|
(semaphore-post to-vm)
|
||||||
|
(set! waiting? #t))))]
|
||||||
|
[(cons meta? e)
|
||||||
|
(define prefix (if meta? "Meta" ""))
|
||||||
|
(match e
|
||||||
|
[(core:presence-event role)
|
||||||
|
(record-event! now "Evt" (string-append prefix "Presence") (format-role role))]
|
||||||
|
[(core:absence-event role reason)
|
||||||
|
(record-event! now "Evt" (string-append prefix "Absence")
|
||||||
|
(string-append (format-role role) " " (~v reason)))]
|
||||||
|
[(core:message-event _ message)
|
||||||
|
(record-event! now "Evt" (string-append prefix "Recv") (~v message))])]))
|
||||||
|
|
||||||
|
(define (controller-thread-loop)
|
||||||
|
(sync (handle-evt from-vm
|
||||||
|
(lambda (x)
|
||||||
|
(handle-from-vm x)
|
||||||
|
(controller-thread-loop)))))
|
||||||
|
|
||||||
|
(super-new)
|
||||||
|
|
||||||
|
(send frame show #t)
|
||||||
|
))
|
Loading…
Reference in New Issue