420 lines
13 KiB
Racket
420 lines
13 KiB
Racket
#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 data/queue)
|
|
|
|
(require racket/pretty)
|
|
|
|
(require (prefix-in core: "../types.rkt")
|
|
(prefix-in core: "../vm.rkt"))
|
|
|
|
(provide 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
|
|
|
|
(struct historical-moment (alive? state endpoints) #:transparent)
|
|
|
|
(define (open-debugger name)
|
|
(define to-debugger (make-channel))
|
|
(define from-debugger (make-channel))
|
|
(parameterize ((current-eventspace (make-eventspace)))
|
|
(new debugger%
|
|
[name name]
|
|
[from-vm to-debugger]
|
|
[to-vm from-debugger]))
|
|
(wrap/unwrapper
|
|
(lambda (v)
|
|
(channel-put to-debugger v)
|
|
(channel-get from-debugger))))
|
|
|
|
;; This is utterly vile.
|
|
(define (wrap/unwrapper thunk)
|
|
(local-require racket/unsafe/ops)
|
|
(lambda (wrapped-val)
|
|
;; (pretty-print `(wrapped-val ,wrapped-val))
|
|
(define inner (unsafe-struct-ref wrapped-val 0))
|
|
;; (pretty-print `(inner ,inner))
|
|
(unsafe-struct-set! wrapped-val 0 (thunk inner))
|
|
wrapped-val))
|
|
|
|
(define sane-tab-panel%
|
|
(class tab-panel%
|
|
(super-new)
|
|
(define/override (place-children l width height)
|
|
(for/list [(child-spec (in-list l))]
|
|
(match-define (list min-w min-h v-stretch? h-stretch?) child-spec)
|
|
(list 0
|
|
0
|
|
(if h-stretch? width min-w)
|
|
(if v-stretch? height min-h))))))
|
|
|
|
(define debugger%
|
|
(class object%
|
|
|
|
(init-field name)
|
|
(init-field from-vm)
|
|
(init-field to-vm)
|
|
|
|
(define mutex (make-semaphore 1))
|
|
(define stepping? #t)
|
|
(define k-queue (make-queue))
|
|
|
|
(define (reply-to-vm reply)
|
|
(call-with-semaphore mutex
|
|
(lambda () (if stepping?
|
|
(channel-put to-vm reply)
|
|
(enqueue! k-queue reply)))))
|
|
|
|
(define current-historical-moment (historical-moment #t (void) '()))
|
|
(define displayed-endpoints '())
|
|
(define booted? #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 state-panel (new sane-tab-panel%
|
|
[parent frame]
|
|
[choices '("Process State")]
|
|
[callback (lambda (p e) (select-state-tab))]))
|
|
|
|
(define endpoints (new list-box%
|
|
[style '(single column-headers)]
|
|
[label #f]
|
|
[choices '()]
|
|
[parent frame]
|
|
[columns '("ID" "" "" "" "Topic")]))
|
|
|
|
(define events (new list-box%
|
|
[style '(single column-headers)]
|
|
[callback (lambda (lb e)
|
|
(define sel (or (send lb get-selection)
|
|
(- (send lb get-number) 1)))
|
|
(define m (and sel (send lb get-data sel)))
|
|
(when m (select-historical-moment m)))]
|
|
[label #f]
|
|
[choices '()]
|
|
[parent frame]
|
|
[columns '("Time" "Dir" "Type" "Detail")]))
|
|
|
|
(define FIXED-COLUMN-WIDTH 40)
|
|
(send endpoints set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
(send endpoints set-column-width 2 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
(send endpoints set-column-width 3 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
|
|
(send events set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
|
|
(define toolbar (new horizontal-pane%
|
|
[parent frame]
|
|
[stretchable-height #f]
|
|
[alignment '(right center)]))
|
|
|
|
(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 (non-empty-queue? k-queue)
|
|
(channel-put to-vm (dequeue! k-queue))))))))
|
|
(toolbar-spacer)
|
|
(define step-button
|
|
(toolbar-button (step-icon #:color run-icon-color)
|
|
(lambda (b e)
|
|
(call-with-semaphore
|
|
mutex
|
|
(lambda ()
|
|
(when (non-empty-queue? k-queue)
|
|
(channel-put to-vm (dequeue! k-queue))))))))
|
|
|
|
(send play-button enable #f)
|
|
(send step-button enable #f)
|
|
|
|
;; (toolbar-spacer)
|
|
;; (toolbar-button "Settings...")
|
|
;; (toolbar-spacer)
|
|
;; (toolbar-button (stop-sign-icon))
|
|
|
|
(define status-indicator
|
|
(new canvas%
|
|
[parent toolbar]
|
|
[min-width 32]
|
|
[min-height 32]
|
|
[stretchable-width #f]
|
|
[style '(transparent no-focus)]
|
|
[paint-callback (lambda (c dc)
|
|
(define mx (/ (send c get-width) 2))
|
|
(define my (/ (send c get-height) 2))
|
|
(define r (/ (min mx my) 2))
|
|
(send dc set-brush
|
|
(if (historical-moment-alive? current-historical-moment)
|
|
"green"
|
|
"red")
|
|
'solid)
|
|
(send dc draw-ellipse (- mx r) (- my r) (* r 2) (* r 2)))]))
|
|
|
|
(define state-text (new text%))
|
|
(define state-canvas (new editor-canvas%
|
|
[parent state-panel]
|
|
[editor state-text]
|
|
[label "State"]))
|
|
|
|
(define vm-display (new list-box%
|
|
[style '(single column-headers)]
|
|
[label #f]
|
|
[choices '()]
|
|
[parent state-panel]
|
|
[columns '("PID" "#Endpoints" "#MetaEndpoints" "Name")]))
|
|
(send vm-display show #f)
|
|
|
|
(define (select-historical-moment m)
|
|
(match-define (historical-moment alive? state new-endpoints) m)
|
|
|
|
(when (not (equal? displayed-endpoints new-endpoints))
|
|
(send endpoints clear)
|
|
(for [(ep (in-list new-endpoints))]
|
|
(match-define (list pre-eid meta? (core:role orientation topic interest-type)) ep)
|
|
(define n (send endpoints get-number))
|
|
(send endpoints append (~v pre-eid))
|
|
(send endpoints set-string n (if meta? "Meta" "") 1)
|
|
(send endpoints set-string n (case orientation
|
|
[(publisher) "Pub"]
|
|
[(subscriber) "Sub"]) 2)
|
|
(send endpoints set-string n (case interest-type
|
|
[(participant) ""]
|
|
[(observer) "Obs"]
|
|
[(everything) "***"]) 3)
|
|
(send endpoints set-string n (~v topic) 4))
|
|
(set! displayed-endpoints new-endpoints))
|
|
|
|
(send state-canvas set-canvas-background
|
|
(if alive?
|
|
(make-color #xff #xff #xff)
|
|
(make-color #xff #xd0 #xd0)))
|
|
|
|
(send status-indicator refresh)
|
|
|
|
(send state-text erase)
|
|
(send state-text insert (pretty-format state))
|
|
|
|
(when (core:vm? state)
|
|
(refresh-vm-display state)
|
|
(when (= 1 (send state-panel get-number))
|
|
(send state-panel append "VM State")
|
|
(send state-panel set-selection 1)
|
|
(select-state-tab))))
|
|
|
|
(define (refresh-vm-display v)
|
|
(define procs (sort (hash->list (core:vm-processes v)) < #:key car))
|
|
(send vm-display clear)
|
|
(for [(entry (in-list procs))]
|
|
(match-define (cons pid wp) entry)
|
|
;;(wp (lambda (p) (displayln `(P ,p))))
|
|
(displayln (cons pid wp))))
|
|
|
|
(define (select-state-tab)
|
|
(define selection (send state-panel get-selection))
|
|
(send state-canvas show (= selection 0))
|
|
(send vm-display show (= selection 1)))
|
|
|
|
(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-data n current-historical-moment)
|
|
(send events set-string n dir 1)
|
|
(send events set-string n type 2)
|
|
(send events set-string n (~a detail) 3)
|
|
(define current-selection (send events get-selection))
|
|
(when (or (not current-selection) (= current-selection (- n 1)))
|
|
(send events set-first-visible-item n)
|
|
(send events set-selection n)
|
|
(select-historical-moment current-historical-moment)))
|
|
|
|
(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 (apply-action! a)
|
|
(cond
|
|
[(core:yield? a) (void)]
|
|
[(core:at-meta-level? a) (apply-preaction! #t (core:at-meta-level-preaction a))]
|
|
[else (apply-preaction! #f a)]))
|
|
|
|
(define (apply-preaction! meta? p)
|
|
(match p
|
|
[(core:quit #f reason)
|
|
(set! current-historical-moment
|
|
(struct-copy historical-moment current-historical-moment
|
|
[alive? #f]))]
|
|
[(core:add-endpoint pre-eid role handler)
|
|
(set! current-historical-moment
|
|
(struct-copy historical-moment current-historical-moment
|
|
[endpoints (append (filter (lambda (e) (not (equal? (car e) pre-eid)))
|
|
(historical-moment-endpoints
|
|
current-historical-moment))
|
|
(list (list pre-eid meta? role)))]))]
|
|
[(core:delete-endpoint pre-eid reason)
|
|
(set! current-historical-moment
|
|
(struct-copy historical-moment current-historical-moment
|
|
[endpoints (filter (lambda (e) (not (equal? (car e) pre-eid)))
|
|
(historical-moment-endpoints
|
|
current-historical-moment))]))]
|
|
[_ (void)]))
|
|
|
|
(define (handle-from-vm x)
|
|
(define now (current-timestamp))
|
|
(match x
|
|
[(core:transition state actions)
|
|
(when (or (not booted?)
|
|
(not (equal? state (historical-moment-state current-historical-moment))))
|
|
(set! booted? #t)
|
|
(set! current-historical-moment
|
|
(struct-copy historical-moment current-historical-moment [state state]))
|
|
(record-event! now "Txn" "State" (~v 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))
|
|
(apply-action! a)
|
|
(record-event! now "Act" type detail)]))
|
|
(reply-to-vm x)]
|
|
[(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))])
|
|
(reply-to-vm x)]))
|
|
|
|
(define (controller-thread-loop)
|
|
(sync (handle-evt from-vm
|
|
(lambda (x)
|
|
(queue-callback (lambda () (handle-from-vm x)))
|
|
(controller-thread-loop)))))
|
|
|
|
(super-new)
|
|
|
|
(select-historical-moment current-historical-moment)
|
|
|
|
(send frame show #t)
|
|
))
|