From 046fcc9347bff23b3fa343a2f682f8c88b9951e7 Mon Sep 17 00:00:00 2001 From: Jono Spiro Date: Sat, 17 Jul 2004 17:33:52 +0000 Subject: [PATCH] made mztake into a tool, updated demos. svn: r103 --- collects/mztake/debugger-tool.ss | 49 +++ collects/mztake/emblem-ohno.png | Bin 0 -> 1678 bytes collects/mztake/info.ss | 6 + collects/mztake/mztake.ss | 415 ++++++++++++++++++ collects/mztake/private/more-useful-code.ss | 292 ++++++++++++ collects/mztake/private/useful-code.ss | 37 ++ .../mztake/stock_macro-check-brackets-16.png | Bin 0 -> 372 bytes .../mztake/stock_macro-check-brackets.png | Bin 0 -> 930 bytes 8 files changed, 799 insertions(+) create mode 100644 collects/mztake/debugger-tool.ss create mode 100644 collects/mztake/emblem-ohno.png create mode 100644 collects/mztake/info.ss create mode 100644 collects/mztake/mztake.ss create mode 100644 collects/mztake/private/more-useful-code.ss create mode 100644 collects/mztake/private/useful-code.ss create mode 100644 collects/mztake/stock_macro-check-brackets-16.png create mode 100644 collects/mztake/stock_macro-check-brackets.png diff --git a/collects/mztake/debugger-tool.ss b/collects/mztake/debugger-tool.ss new file mode 100644 index 0000000000..604288fe47 --- /dev/null +++ b/collects/mztake/debugger-tool.ss @@ -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)))) \ No newline at end of file diff --git a/collects/mztake/emblem-ohno.png b/collects/mztake/emblem-ohno.png new file mode 100644 index 0000000000000000000000000000000000000000..f684a453f28e8ab8655eacb8a0dc06654966551d GIT binary patch literal 1678 zcmV;9266d`P)<6t{9gc!$F6CzsD3Q<8LC`hdf zq6+X3Br1i1korK85Vzuo(kJ?WUn&b#5TSxV3MffSYN={N#3iV)nyTQ&Auh;qnmBRl zc-Oo3?zzl-JnXD>ViwyVBwiTl+u3t=&iDU+m-){g`2YAH5A|=Z9{>&l_W^r=ZhwCc zm;g=#zXC4)w+RdY!+l-hp>KS)n~%P~jqP0_jUhPaC@#lLUynKcmlDsM$TPcOe-1pk z5h5EQ@F*~PbhzI!2Er-?ytu$lfc?PyO`7Gc+1aUAnzQ~T=kfNXg^u#1%XA7vV52KVqD+MTCI#=WiPhaKKYs)lt_M?=d zsX_C#PqzV#dY>C6FnsiTJI%Jv(5G9W&CU1436bGN00pRe+HClV`Mr#2j zbhK!`{+VV23~!XcKwnpQXy~3zCm$hr@xtnTU6i#5zdjdAMsYCU$ zP>;aDZ+@;Dt?@7hM1=hkR?+o!8vMz!9KC-tNae_F9 z5?760EWdebHvp%9`K=XVf?%yM@|7L{e)8lHg})s~1Y82Ct*&|Ry9{2yZW%!x0(-hU z0<2iX3Qh#2ATWvt_P2BSjbro$=V9^(2o8nAiQ|#`J2>$0p-eRx0PRF;qnv}Ye^CziiFfT zG(u}r)%QjS5G5&s5Ez5g4y`rf6rv%x`8p!ix;rPN))FO_inS~)zC|fcDMyxa?1-Ji zT0v{b1@#*?s3XmD`EuIR<{&geU^Iadi~;QwNdgm>DokC8a8dWyf-4No;lJ7%ki=IDqrM@m-CCSp}|v+jjMu1HGFKDULK1 ztQN!y6PGF+KU3s~#}}Bnky1&-mrR(xp7QHcm+0TUmnLpdjvT3V1V(5KVf>=y+~3`E zz?p0Y^eS)zJpb&AMGEDV!eUA>N?0tU6qhYaWy_J53u~TUPak=ehR)k5M}l(@=&Fbv zdo=+V0~$Pz0+gZI4i!Dg<4}MC4>epUUiJVn27(A`bXdz zFzfAxCr}3BYzb<8kn=>Ey)6Kj&t9}`XQ$H5%?*$XgfOVixv+Xxlq$l7w}l_S9P_&g zHw~Nu-U60@5>WK>vX4Hgl|W~<&Z}9N(U6*s)cn|tpIY>Jpa3jpqX#6& zsFL&DUvp-G*w-rWqiyoN5_nrpz-9k07*qoM6N<$f{a%R!~g&Q literal 0 HcmV?d00001 diff --git a/collects/mztake/info.ss b/collects/mztake/info.ss new file mode 100644 index 0000000000..1bf898c267 --- /dev/null +++ b/collects/mztake/info.ss @@ -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"))) +) diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss new file mode 100644 index 0000000000..f43ca6f98e --- /dev/null +++ b/collects/mztake/mztake.ss @@ -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))])) + ) \ No newline at end of file diff --git a/collects/mztake/private/more-useful-code.ss b/collects/mztake/private/more-useful-code.ss new file mode 100644 index 0000000000..ab771be2f5 --- /dev/null +++ b/collects/mztake/private/more-useful-code.ss @@ -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) "#"] + [(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)))) diff --git a/collects/mztake/private/useful-code.ss b/collects/mztake/private/useful-code.ss new file mode 100644 index 0000000000..bfb60d1369 --- /dev/null +++ b/collects/mztake/private/useful-code.ss @@ -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))))) \ No newline at end of file diff --git a/collects/mztake/stock_macro-check-brackets-16.png b/collects/mztake/stock_macro-check-brackets-16.png new file mode 100644 index 0000000000000000000000000000000000000000..98dcd84a30c25840c962a50ca4529554fda44a73 GIT binary patch literal 372 zcmV-)0gL{LP)iu!65`c>z#ew6n2214*vYf_=+2hC0s8~a1!F|zzXm1F)4-@A)Z!s@jD9a;7{U3#3%en zis5bO-n}=ms*5wMA7tBb@A=NN2==L5DVxG`37&$uIggn004R=004l4008;_004mI004C^008P=0026d000+nY2?H!0009m zNklR70tg^Nh%q+2S`SDwgV@*<#7ETWK;@aR zsR0Ne7F;Grhg8V2va(NNWMohUa;<^*I}rZ{;{V7FU}9og6(3Q1{ocbXWrvTie*#tW z52gShfS9lu4s^9X8ym+NAk+Ndv32o4nirR2o;2KBTz~+= zuplzHjE9ApbrT~aquAT`&llZ$a2e#Hzfg<;b{|;!^v92Hii17Zsx7J>5r{rK_q8q5HGJ`r~y#RqaL z$UJ}m!eRlVCRo?MzhD0T`}+rK_#Y$-CIWFA5Su_P`Ty$elQ&2qpa}H=*aCn6!e#*v z%m+|I&msj6%n}tKZUEvQAU1#V_SsLk0ZdF>43Ibg2N6I3VWf=z|Nngf1`|KfB4((8 zpp@~J0TIa{vEx9z6^OS1@f&p&BW{>}pwB@;3d<9W00D$y!M}h1t}-(-Spic84>J=B z^WT4e&@)dy5T69%yCB0s0=zsz!Z697KfgU-faC+Pj{yP*J&6AQ`u%ewG_07_RE%U8 zFmv%Fs0HwF=V0ejhp}J0dUOa#{a}E^8v{T9VOVhC@`1U3|NeOh;wZ}NSOO_l21q8u zT2z3(y6A+3 zsn-&q7&p`>=)Pd&;Naf#`}fc7dk!v(dGPq!U8vz-7@&y)Ab@Zokj0?nCTU{m>IkG| zpq5}*;O&+SDotg9SQ&^VfS8j3sVo8rAY9=JvjpU7b|@bdaTuj3R1F7I9F!kGkqa+P z0Rjl01u%ISh9y00YM2-h84*PdKmgGk0R#}u5kP