suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

made mztake into a tool, updated demos.

Browse Source 
svn: r103
This commit is contained in:
Jono Spiro 2004-07-17 17:33:52 +00:00
parent fcf7f29630
commit 046fcc9347
8 changed files with 799 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mztake/debugger-tool.ss Normal file
View File

@ -0,0 +1,49 @@
(module debugger-tool mzscheme
(require (lib "contract.ss")
(lib "tool.ss" "drscheme")
(lib "mred.ss" "mred")
(prefix frame: (lib "framework.ss" "framework"))
(lib "unitsig.ss")
(lib "class.ss")
(lib "list.ss"))
(provide tool@)
(define tool@
(unit/sig drscheme:tool-exports^
(import drscheme:tool^)
(define (phase1) (void))
(define (phase2) (void))
(define debugger-bitmap
(drscheme:unit:make-bitmap
"Syntax Offset"
(build-path (collection-path "mztake") "stock_macro-check-brackets.png")))
(define (debugger-unit-frame-mixin super%)
(class super%
(inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar)
(super-instantiate ())
(define debugger-button
(make-object button%
(debugger-bitmap this)
(get-button-panel)
(lambda (button evt)
(let* ([pos (send (get-definitions-text) get-start-position)]
[line (send (get-definitions-text) position-paragraph pos)]
[column (- pos (send (get-definitions-text) line-start-position
(send (get-definitions-text) position-line pos)))])
(message-box/custom "Syntax Offset"
(format "Line: ~a~nColumn: ~a~nOffset: ~a" (add1 line) column pos)
"OK"
#f #f #f
'(default=1))))))
(send (get-button-panel) change-children
(lambda (_) (cons debugger-button (remq debugger-button _))))))
(drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin))))

BIN
collects/mztake/emblem-ohno.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

6
collects/mztake/info.ss Normal file
View File

@ -0,0 +1,6 @@
(module info (lib "infotab.ss" "setup")
(define name "Debugger")
(define tools '(("debugger-tool.ss")))
(define tool-names '("The Debugger"))
(define tool-icons '(("emblem-ohno.png" "mztake")))
)

415
collects/mztake/mztake.ss Normal file
View File

@ -0,0 +1,415 @@
#| TODO
LOOK AT (require (lifted mzscheme random)) in demos/random-xs-test.ss -- there seems to be a problem with requires that do lifting for FrTime in the target program, we need to do requires in the script for some reason. random becomes random3 and throws an exception.
code like
(set-running! client (or (elapsed . < . 5) (elapsed . >= . 10)))
(set-running! client #t)
will break the behavior ... it gets set!'d. Fix this!
rethink start/resume and kill -- do we want people to be able to restart after a kill or the progam exits (we have a behavior to check for that)?
RETHROW EXCEPTIONS CAUGHT ON THE STREAM FOR A CLIENT -- OFFER A WAY TO DISABLE IT
Need a way to define which language to evaluate the target with. Robby should know how: robby@cs.uchicago.edu
Does this work with modules? with frtime?
You cannot annotate across requires. Test threads and multiple clients. Two files at the same time if they use each other?
DrScheme has hooks which should let me bind to the 'load's of libraries and force loading source, then annotating after expansion.
DEMOS---------------------------------------------------------------------------------------
Data structure examples
Binary search over a tree, show which node is being examined, or the most commonly taken path
Parse, graph the AST -- show OR and AND precedence getting messed up
MST example
Code something with multiple threads doing something and draw the threads in different colors in a window
SCRIPT--------------------------------------------------------------------------------------
provide a running? behavior for the scripts, which actually works.
make (script-error) map to some exception stream for script errors only.
For now it is a synonym for (display)
Find a way to signal the error outside of FrTime's eventspace so that it doesnt loop the error endlessly
add a trace/break function.
make script errors highlight the location of the error
let traces take a line number without offset and find the first bindable location.
OPTIMIZATIONS-------------------------------------------------------------------------------
get rid of references to stepper and move files like marks.ss over to debugger
improve speed of lookup for line-col->pos; load them into a hashtable? not important since this is just startup time for the script.
ERROR-CHECKING------------------------------------------------------------------------------
Test what happens when you bind to variables that don't exist.
This throws an exception where it says something like random210 is an undefined variable
The script does not tell you something went wrong though, and the solution (as-is/unchecked) is not obvious.
(require (as-is mzscheme random random-seed))
(random 100)
TESTING/CAPABILITIES------------------------------------------------------------------------
If you pause after a value = 14000, it doesn't pause until the 14001th iteration. Keep this in mind.
Does user interaction work? Can we step through loops one line at a time waiting for input? GUIs?
Verify that when killing the debugger, all the memory and bindings that need to be released are released.
code the heap example and copy the set-running! coolness to it from sine-test.ss
Can you duplicate the problem when the program seems to keep running event after killing it?
We want a way to interactively step through code one line at a time when we hit a breakpoint. Provide way to check bindings at the same time -- EVEN IF NOT BOUND USING TRACE/BIND
Map kill or pause to the Break button?
trace/bind what kind of interface do we want to dig into frames
write a nested syntax for bind so that you can take a first-class function that defines a way to return variables, not just as a list
What do we do about binding to a variable and following it EVERYWHERE it goes. Even if it is assigned to something else. Need to talk to Shriram, Greg, and Guillaume about this.
Find a way to bind to the result of ananonymous expression: here->(add1 2)
|#
(module mztake mzscheme
(require
(lib "match.ss")
(lib "contract.ss")
(lib "unitsig.ss")
(rename (lib "mred.ss" "mred") make-eventspace make-eventspace)
(rename (lib "mred.ss" "mred") current-eventspace current-eventspace)
(rename (lib "mred.ss" "mred") eventspace-shutdown? eventspace-shutdown?)
(rename (lib "mred.ss" "mred") queue-callback queue-callback)
(lib "debugger-model.ss" "stepper" "private")
(lib "marks.ss" "stepper" "private")
"private/useful-code.ss" ; provides stuff for scripts -- history-b etc...
"private/more-useful-code.ss" ; mostly for hash- bindings
(prefix frp: (lib "frp.ss" "frtime")))
; Provides come from the script section at the bottom of the code
(provide kill
pause
trace/bind
set-running!
client-exit?
start/resume
create-client
client-exceptions
client-runtime-seconds
client-runtime-milliseconds
(rename script-running? client-running?))
;######################## STRUCTS ########################
(define-struct trace (evnt-rcvr)) ; frp:event-receiver
(define-struct (bind-trace trace)
(variable-to-bind)) ; symbol
(define-struct client (filename ; string
tracepoints ; hash-table of traces
running? ; boolean - is the program (supposed-to-be) currently running
custodian ; if you shutdown-all it will kill the debugger
run-semaphore ; when you post to this the debuggee will continue executing
exceptions ; (an event stream) exceptions thrown during the evaluation of the target
exit? ; (an cell) receives #t when the target exits
runtime ; behavior with current runtime in milliseconds
line-col->pos)); memoized O(n) function to map line/col -> byte offset
;#################### STRUCT-BUILDERS #####################
; Creates a trace that binds to the value of a variable in scope
(define/contract create-bind-trace
((union (listof symbol?) symbol?) . -> . trace?)
(lambda (sym-to-bind)
(make-bind-trace (frp:event-receiver) sym-to-bind)))
;####################### CALLBACKS #######################
; Callback for when a breakpoint (tracepoint) is hit by the model
; ((client) breakpoint-struct) -> ()
(define ((receive-result client) result)
(match result
; regular breakpoint
[($ normal-breakpoint-info (top-mark rest-mark ...) kind)
(let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))]
[trace-hash (client-tracepoints client)]
[traces (hash-get trace-hash byte-offset)])
(assert (not (empty? traces))
(format "There are no traces at offset ~a, but a breakpoint is defined!"
(number->string byte-offset)))
; Run all traces at this breakpoint
(let ([to-send (map (lambda (t) (trace->frp-event client result t)) traces)])
(frp:send-synchronous-events to-send)))]
; now, breakpoint-halt message should be sent by the debugger model
;TODO eventually remove this from debugger-model.ss
[($ error-breakpoint-info message)
(assert false)]
;end of a statement
[($ breakpoint-halt)
; do we want to pause interactive debugging
(when (running-now? client)
(semaphore-post (client-run-semaphore client)))]
;when a top level expression finishes
[($ expression-finished return-val-list) (void)]
[else-struct
(assert false)(printf "something else hit: ~a~n" else-struct)]))
;################### DEBUGGER BACKEND ####################
; retreives the binding of a variable from a breakpoint event
(define (binding event sym)
(let ([mark-list (normal-breakpoint-info-mark-list event)]
[current-frame-num 0])
(map (lambda (binding) (list (mark-binding-binding binding)
(mark-binding-value binding)))
(lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym))
(do-n-times cdr current-frame-num mark-list)))))
; does something for (binding)
(define (do-n-times fn n arg)
(foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x))))
; wrapper for errors related to the script only
(define (script-error err)
; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up
; it could easily be an (error)
(display (format "script-error: ~a~n" err)))
(define (fatal-script-error err client)
(script-error err)
(kill client))
; takes a single trace, looks up what it needs to do, and returns an frp-event to publish
(define (trace->frp-event client event trace)
(match trace
[($ bind-trace evnt-rcvr variable-to-bind)
(let* ([vars (if (list? variable-to-bind) variable-to-bind
(list variable-to-bind))]
[values (map (lambda (var)
(let ([val (binding event var)])
(if (empty? val)
(fatal-script-error (format "No binding found in trace for symbol '~a" var)
client)
(cadar (binding event var)))))
vars)])
(list evnt-rcvr
(if (list? variable-to-bind) values
(first values))))]))
; TODO improve program expander
(define ((program-expander filename) init callback)
;; (init) ; TODO now that's a bit of a hack.
(parameterize ([port-count-lines-enabled #t])
(let ([port (open-input-file filename)])
(begin0
(let loop ([stx (read-syntax filename port)])
(unless (eof-object? stx)
(callback
(expand stx)
(lambda () (loop (read-syntax filename port))))))
(close-input-port port)))))
(define (start-debugger client)
(let* ([breakpoint-origin (client-filename client)]
[breakpoints (hash-keys (client-tracepoints client))]
[program-expander (program-expander breakpoint-origin)]
[receive-result (receive-result client)])
; connect to the debugger-model@ unit
(define-values/invoke-unit/sig (go go-semaphore user-custodian)
debugger-model@
#f ; prefix
(receive-result)
(program-expander)
; breakpoint-origin = filename from thunk of (program-expander)
(breakpoints breakpoint-origin))
; set initial state of exit predicate
(frp:set-cell! (client-exit? client) #f)
(set-client-run-semaphore! client go-semaphore)
(set-client-custodian! client user-custodian)
; we run the program under its own custodian so we can easily kill it...that's IT
(let ([evaluation-thread
(parameterize ([current-custodian user-custodian])
(thread
(lambda ()
; all errors and raises from the TARGET program will be caught here
; FrTime errors from the script have their own eventstream
(with-handlers ([(lambda (exn) #t)
(lambda (exn) (frp:send-event (client-exceptions client) exn))])
(go)))))])
(thread (lambda ()
(thread-wait evaluation-thread)
; program terminates
(kill client))))))
; Switches the running state on or off
; (client [boolean]) -> ()
(define/contract set-running! (client? (union frp:behavior? boolean?) . -> . void?)
(lambda (client run?)
(define (update)
; (re)start the debugger if needed
(when (null? (client-run-semaphore client)) (start-debugger client))
(when run? (semaphore-post (client-run-semaphore client)))
(frp:value-now run?))
(cond [(frp:behavior? run?)
(set-client-running?! client (frp:proc->signal update run?))]
[else (set-client-running?! client run?)
(update)])
(void)))
; returns a memoized function that takes (line column) -> position
(define/contract line-col->pos (client? . -> . (number? number? . -> . (union void? number?)))
(lambda (client)
(let ([filename (client-filename client)])
; produces a nested list of (line column offset) for all addressable syntax
(define (unwrap-syntax stx)
(let ([elt (list (syntax-line stx)
(syntax-column stx)
(sub1 (syntax-position stx)))])
(syntax-case stx ()
[(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))]
[x elt])))
(let ([pos-list
(flatten (parameterize ([port-count-lines-enabled #t])
(let ([port (open-input-file filename)])
(begin0
(let loop ([stx (read-syntax filename port)])
(if (eof-object? stx) '()
(cons (unwrap-syntax stx)
(loop (read-syntax filename port)))))
(close-input-port port)))))])
(lambda (line col)
(let loop ([lst pos-list]
[last-coord (first pos-list)])
(cond
; none is found
[(empty? lst)
(fatal-script-error (format "No syntax found for trace at line/column ~a:~a in ~a" line col filename)
client)]
; if first is correct line and correct column
[(and (= line (caar lst))
(= col (cadar lst)))
(third (first lst))]
[else (loop (rest lst)
(first lst))])))))))
; predicate - is the debugee supposed to be running now?
(define (running-now? client)
(and (not (null? (client-run-semaphore client)))
(frp:value-now (client-running? client))))
; returns a behavior for a client counting runtime
; this is set!'d into the client struct so that it is always accurate
(define (runtime c)
(frp:hold
((frp:changes
(frp:accum-b
((frp:changes frp:milliseconds)
. frp:-=> .
(match-lambda [(prev sum)
(if (frp:value-now (client-running? c))
(list (frp:value-now frp:milliseconds)
(+ (- (frp:value-now frp:milliseconds) prev) sum))
(list (frp:value-now frp:milliseconds) sum))]))
(list (frp:value-now frp:milliseconds) 0)))
. frp:==> .
second)
0))
;#################### SCRIPT FUNCTIONS ###################
(define script-running?
(lambda (client)
(print "client-running? is broken")
(and (running-now? client)
(not (client-exit? client)))))
(define/contract client-runtime-milliseconds (client? . -> . frp:behavior?)
(lambda (client)
(client-runtime client)))
(define/contract client-runtime-seconds (client? . -> . frp:behavior?)
(lambda (client)
(frp:hold ((frp:changes (client-runtime client))
. frp:==> .
(lambda (t) (truncate (/ t 1000))))
0)))
; Creates a debugger client
; (string) -> (client)
(define/contract create-client (string? . -> . client?)
(lambda (filename)
(let ([c (make-client filename (make-hash) #f null null
(frp:event-receiver) (frp:new-cell) null null)])
; set curried line-col->pos function for client
(set-client-line-col->pos! c (line-col->pos c))
; set the runtime info (runtime-evs, time-behavior)
(set-client-runtime! c (runtime c))
c)))
(define (pause c) (set-running! c #f))
(define (start/resume c) (set-running! c #t))
; Kills the debugger immediately
; (client) -> ()
(define/contract kill (client? . -> . void?)
(lambda (client)
(pause client)
; shutdown the custodian
(custodian-shutdown-all (client-custodian client))
(set-client-custodian! client null)
(set-client-run-semaphore! client null)
; set the exit predicate to 'exited'
(frp:set-cell! (client-exit? client) #t)))
; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver)
(define/contract trace/bind (case->
(client? number? (union symbol? (listof symbol?)) . -> . frp:event?)
(client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?))
(case-lambda
[(client line col binding-symbol)
(trace/bind client ((client-line-col->pos client) line col) binding-symbol)]
[(client pos binding-symbol)
(let ([trace-hash (client-tracepoints client)]
[trace (create-bind-trace binding-symbol)])
; add the trace to the list of traces for that byte-offset
(hash-put! trace-hash pos
(cons trace
(hash-get trace-hash pos (lambda () '()))))
(trace-evnt-rcvr trace))]))
)

292
collects/mztake/private/more-useful-code.ss Normal file
View File

@ -0,0 +1,292 @@
(module more-useful-code mzscheme
(require (lib "list.ss")
(lib "pretty.ss")
(lib "etc.ss"))
(provide assert
cons-to-end
assoc-get
debug
make-to-string
make-debug
to-string
member-eq?
string->char
last
member-str?
quicksort-vector!
struct->list/deep
make-for-each
begin0/rtn
with-handlers/finally
pretty-print-syntax
with-semaphore
make-hash
hash?
hash-get
hash-put!
hash-remove!
hash-map
hash-for-each
hash-size/slow
hash-mem?
hash-fold
hash-filter!
hash-keys
hash-values
hash-pairs
hash-add-all!
hash-get-or-define!
(all-from (lib "list.ss"))
(all-from (lib "etc.ss")))
(define-struct (exn:assert exn) ())
(define-syntax (assert stx)
(syntax-case stx ()
[(src-assert bool) #'(src-assert bool "")]
[(src-assert bool msg ...)
(with-syntax ([src-text (datum->syntax-object
(syntax src-assert)
(format "~a:~a:~a: assertion failed: "
(syntax-source (syntax bool))
(syntax-line (syntax bool))
(syntax-column (syntax bool))))])
#'(unless bool
(raise (make-exn:assert (apply string-append
(cons src-text
(map (lambda (item)
(string-append (to-string item) " "))
(list msg ...))))
(current-continuation-marks)))))]))
(define-syntax (begin0/rtn stx)
(syntax-case stx ()
[(begin0/rtn body bodies ...)
(with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)])
(syntax (let ([rtn body]) bodies ... rtn)))]))
(define-syntax with-handlers/finally
(syntax-rules ()
[(_ (handler ...) body finally)
(let ([finally-fn (lambda () finally)])
(begin0
(with-handlers
(handler ...
[(lambda (exn) #t)
(lambda (exn) (finally-fn) (raise exn))])
body)
(finally-fn)))]))
(define (make-for-each . iterator-fns)
(lambda (obj fn)
(cond ((list? obj) (for-each fn obj))
((vector? obj) (let loop ((x 0))
(if (< x (vector-length obj))
(begin (fn (vector-ref obj x)) (loop (+ x 1))))))
((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key))))
(true (let loop ((cur iterator-fns))
(if (empty? cur)
(if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj)
(error "for-each: no iterator for value:" obj))
(or ((first cur) obj fn)
(loop (rest cur)))))))))
(define (quicksort-vector! v less-than)
(let ([count (vector-length v)])
(let loop ([min 0][max count])
(if (< min (sub1 max))
(let ([pval (vector-ref v min)])
(let pivot-loop ([pivot min]
[pos (add1 min)])
(if (< pos max)
(let ([cval (vector-ref v pos)])
(if (less-than cval pval)
(begin
(vector-set! v pos (vector-ref v pivot))
(vector-set! v pivot cval)
(pivot-loop (add1 pivot) (add1 pos)))
(pivot-loop pivot (add1 pos))))
(if (= min pivot)
(loop (add1 pivot) max)
(begin
(loop min pivot)
(loop pivot max)))))))))
v)
(define (member-str? s ls)
(cond
((empty? ls) false)
((string=? s (first ls)) true)
(else (member-str? s (rest ls)))))
(define (last ls)
(cond
((empty? ls) (error "took a last but it was emptry"))
((empty? (rest ls)) (first ls))
(else (last (rest ls)))))
(define (string->char s)
(first (string->list s)))
(define (member-eq? x ls)
(not (empty? (filter (lambda (y) (eq? x y)) ls))))
(define (to-string arg . extra-printers)
(let ([on-stack-ids (make-hash)]
[used-ids (make-hash)]
[free-id 0])
(let loop ((arg arg))
(if (hash-mem? on-stack-ids arg)
(begin
(hash-put! used-ids arg true)
(format "#~a#" (hash-get on-stack-ids arg)))
(let ([my-id free-id])
(hash-put! on-stack-ids arg my-id)
(set! free-id (add1 free-id))
(let ([result
(or
(let printer-loop ([printers extra-printers])
(if (empty? printers)
false
(or (if (procedure-arity-includes? (car printers) 2)
((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers))))
((car printers) arg))
(printer-loop (cdr printers)))))
(cond
[(not arg) "#f"]
[(void? arg) "#<void>"]
[(eq? arg #t) "#t"]
[(char? arg) (list->string (list arg))]
[(string? arg) (format "\"~a\"" arg)]
[(symbol? arg) (symbol->string arg)]
[(number? arg) (number->string arg)]
[(vector? arg) (string-append "#" (loop (vector->list arg)))]
[(box? arg) (string-append "#&" (loop (unbox arg)))]
[(empty? arg) "empty"]
[(list? arg)
(apply
string-append
`("(" ,@(cons (loop (first arg))
(map (lambda (item) (string-append " " (loop item))) (rest arg)))
")"))]
[(cons? arg) (format "(~a . ~a)"
(loop (first arg))
(loop (rest arg)))]
[(hash-table? arg)
(apply
string-append
`("[hash:"
,@(map (lambda (item) (string-append " " (loop item))) (hash-pairs arg))
"]"))]
[(syntax? arg)
(format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg))]
[(struct? arg)
(let ([as-list (vector->list (struct->vector arg))])
(apply
string-append
`("[" ,@(cons (loop (first as-list))
(map (lambda (item) (string-append " " (loop item)))
(rest as-list))) "]")))]
[else
(format "~a" arg)]))])
(hash-remove! on-stack-ids arg)
(if (hash-mem? used-ids arg)
(format "#~a=~a" my-id result)
result)))))))
;; make-debug: usage example: (define debug-f (make-debug (make-to-string `([,is-type? ,type-to-string]))))
;; The printers have to take two arguments: the item to converts and the to-string function for subitems
(define (make-debug to-string-fn)
(lambda args
(for-each (lambda (x)
(display (if (string? x) x (to-string-fn x)))
(display " "))
args)
(newline)))
(define debug (make-debug to-string))
(define (make-to-string predicate-printer-pairs)
(let ([printers (map (lambda (pair) (lambda (arg printer)
(cond [(not ((first pair) arg)) false]
[(procedure-arity-includes? (second pair) 2)
((second pair) arg printer)]
[else ((second pair) arg)])))
predicate-printer-pairs)])
(case-lambda
[(arg) (apply to-string arg printers)]
[(arg extra-printers) (apply to-string (append (list arg) printers extra-printers))])))
(define (assoc-get label ls)
(cond
((empty? ls) (error (string-append "failed to find " (to-string label))))
((eq? label (first (first ls)))
(first ls))
(else (assoc-get label (rest ls)))))
(define (cons-to-end a ls)
(cond
((empty? ls) (cons a ls))
(else (cons (first ls)
(cons-to-end a (rest ls))))))
(define (struct->list/deep item)
(cond [(struct? item) (map struct->list/deep (vector->list (struct->vector item)))]
[(list? item) (map struct->list/deep item)]
[(vector? item) (list->vector (map struct->list/deep (vector->list item)))]
[else item]))
(define (struct-name s) (vector-ref (struct->vector s) 0))
(define (pretty-print-syntax width stx)
(pretty-print-columns width)
(pretty-print (syntax-object->datum stx)))
(define (with-semaphore sem proc)
(semaphore-wait sem)
(let ([result (proc)])
(semaphore-post sem)
result))
(define make-hash make-hash-table)
(define hash? hash-table?)
(define hash-get hash-table-get)
(define hash-put! hash-table-put!)
(define hash-remove! hash-table-remove!)
(define hash-map hash-table-map)
(define hash-for-each hash-table-for-each)
(define (hash-empty? hash)(let/ec k (hash-for-each hash (lambda (k v) (k false))) true))
(define (hash-size/slow hash) (hash-fold hash 0 (lambda (key val acc) (+ acc 1))))
(define (hash-mem? hash item) (let/ec k (begin (hash-get hash item (lambda () (k false))) true)))
(define (hash-fold hash init fn)
(hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
(define (hash-filter! hash predicate)
(hash-for-each
hash (lambda (key val) (if (not (predicate key val))
(hash-remove! hash key)))))
(define (hash-keys hash)
(hash-fold hash empty (lambda (key val acc) (cons key acc))))
(define (hash-values hash)
(hash-fold hash empty (lambda (key val acc) (cons val acc))))
(define (hash-pairs hash)
(hash-fold hash empty (lambda (key val acc) (cons (cons key val) acc))))
(define (hash-add-all! to-hash from-hash) ;; // memcpy-style argument order
(hash-for-each from-hash
(lambda (key val) (hash-put! to-hash key val))))
(define (hash-get-or-define! hash key val-fn)
(if (not (hash-mem? hash key))
(begin (let ((v (val-fn)))
(hash-put! hash key v)
v))
(hash-get hash key))))

37
collects/mztake/private/useful-code.ss Normal file
View File

@ -0,0 +1,37 @@
(module useful-code (lib "frtime.ss" "frtime")
(require (lib "string.ss")
(lib "contract.ss")
(lib "list.ss")
(lifted mzscheme list*))
(provide (all-defined-except list*))
; Keeps a list of the last n values of a behavior
(define (history-b n stream)
(define ((add-to-hist thing) hist) (append (if ((length hist) . < . n) hist (rest hist)) (list thing)))
(accum-b (stream . ==> . add-to-hist) empty))
; Counts number of event pings on an eventstream
(define (count-e evs)
(accum-b (evs . -=> . add1) 0))
; Counts number of times a behavior updates/changes
(define (count-b b)
(accum-b ((changes b) . -=> . add1) 0))
; Matches a sequence of items in a list to event pings
(define (sequence-match? seq evs)
(equal? seq (history-b (length seq) evs)))
; Reaaaalllly cheap print function
(define (print-b str b)
(format "~a ~a" str b))
; Flattens a list
(define (flatten x)
(cond ((empty? x) '())
((and (list? x)
(list? (first x)))
(append (flatten (car x)) (flatten (cdr x))))
(else (list x)))))

BIN
collects/mztake/stock_macro-check-brackets-16.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 372 B

BIN
collects/mztake/stock_macro-check-brackets.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 930 B