commit 0bf3b604ac87dea526ed2e53c43e3457d5ad93ed parent 8352e11979282b36702f67aa7915d79bd83960a3 Author: Eli Barzilay <eli@barzilay.org> Date: Mon, 17 May 2010 01:27:03 -0400 A lot of "DrScheme" -> "DrRacket"s. original commit: de0cc7771b3f4be098cfa30e552f0acad3436a0e Diffstat:
79 files changed, 1951 insertions(+), 1957 deletions(-)
diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.rkt diff --git a/collects/macro-debugger/info.ss b/collects/macro-debugger/info.rkt diff --git a/collects/macro-debugger/model/context.ss b/collects/macro-debugger/model/context.rkt diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.rkt diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.rkt diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.rkt diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.rkt diff --git a/collects/macro-debugger/model/deriv-util.rkt b/collects/macro-debugger/model/deriv-util.rkt @@ -0,0 +1,71 @@ + +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax racket/private/struct-info) + scheme/list + scheme/match + unstable/struct + "deriv.ss") + +(provide make + + Wrap + + ok-node? + interrupted-node? + + wderiv-e1 + wderiv-e2 + wlderiv-es1 + wlderiv-es2 + wbderiv-es1 + wbderiv-es2 + + wderivlist-es2) + +;; Wrap matcher +;; Matches unwrapped, interrupted wrapped, or error wrapped +(define-match-expander Wrap + (lambda (stx) + (syntax-case stx () + [(Wrap S (var ...)) + (syntax/loc stx (struct S (var ...)))]))) + +;; ---- + +(define (check sym pred type x) + (unless (pred x) + (raise-type-error sym type x))) + +(define (ok-node? x) + (check 'ok-node? node? "node" x) + (and (node-z1 x) #t)) +(define (interrupted-node? x) + (check 'interrupted-node? node? "node" x) + (not (node-z2 x))) + + +(define (wderiv-e1 x) + (check 'wderiv-e1 deriv? "deriv" x) + (node-z1 x)) +(define (wderiv-e2 x) + (check 'wderiv-e2 deriv? "deriv" x) + (node-z2 x)) + +(define (wlderiv-es1 x) + (check 'wlderiv-es1 lderiv? "lderiv" x) + (node-z1 x)) +(define (wlderiv-es2 x) + (check 'wlderiv-es2 lderiv? "lderiv" x) + (node-z2 x)) + +(define (wbderiv-es1 x) + (check 'wbderiv-es1 bderiv? "bderiv" x) + (node-z1 x)) +(define (wbderiv-es2 x) + (check 'wbderiv-es2 bderiv? "bderiv" x)) + +;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f +(define (wderivlist-es2 xs) + (let ([es2 (map wderiv-e2 xs)]) + (and (andmap syntax? es2) es2))) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss @@ -1,71 +0,0 @@ - -#lang scheme/base -(require (for-syntax scheme/base) - (for-syntax scheme/private/struct-info) - scheme/list - scheme/match - unstable/struct - "deriv.ss") - -(provide make - - Wrap - - ok-node? - interrupted-node? - - wderiv-e1 - wderiv-e2 - wlderiv-es1 - wlderiv-es2 - wbderiv-es1 - wbderiv-es2 - - wderivlist-es2) - -;; Wrap matcher -;; Matches unwrapped, interrupted wrapped, or error wrapped -(define-match-expander Wrap - (lambda (stx) - (syntax-case stx () - [(Wrap S (var ...)) - (syntax/loc stx (struct S (var ...)))]))) - -;; ---- - -(define (check sym pred type x) - (unless (pred x) - (raise-type-error sym type x))) - -(define (ok-node? x) - (check 'ok-node? node? "node" x) - (and (node-z1 x) #t)) -(define (interrupted-node? x) - (check 'interrupted-node? node? "node" x) - (not (node-z2 x))) - - -(define (wderiv-e1 x) - (check 'wderiv-e1 deriv? "deriv" x) - (node-z1 x)) -(define (wderiv-e2 x) - (check 'wderiv-e2 deriv? "deriv" x) - (node-z2 x)) - -(define (wlderiv-es1 x) - (check 'wlderiv-es1 lderiv? "lderiv" x) - (node-z1 x)) -(define (wlderiv-es2 x) - (check 'wlderiv-es2 lderiv? "lderiv" x) - (node-z2 x)) - -(define (wbderiv-es1 x) - (check 'wbderiv-es1 bderiv? "bderiv" x) - (node-z1 x)) -(define (wbderiv-es2 x) - (check 'wbderiv-es2 bderiv? "bderiv" x)) - -;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f -(define (wderivlist-es2 xs) - (let ([es2 (map wderiv-e2 xs)]) - (and (andmap syntax? es2) es2))) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.rkt diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.rkt diff --git a/collects/macro-debugger/model/reductions-config.ss b/collects/macro-debugger/model/reductions-config.rkt diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.rkt diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.rkt diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.rkt diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.rkt diff --git a/collects/macro-debugger/model/trace-raw.ss b/collects/macro-debugger/model/trace-raw.rkt diff --git a/collects/macro-debugger/model/trace.rkt b/collects/macro-debugger/model/trace.rkt @@ -0,0 +1,153 @@ + +#lang scheme/base +(require scheme/promise + parser-tools/lex + "deriv.ss" + "deriv-parser.ss" + "deriv-tokens.ss") + +(provide trace + trace* + trace/result + trace-verbose? + events->token-generator + current-expand-observe + expand/compile-time-evals + + trace-macro-limit + trace-limit-handler) + +(define current-expand-observe + (dynamic-require ''#%expobs 'current-expand-observe)) + +(define trace-verbose? (make-parameter #f)) + +;; trace : stx -> Deriv +(define (trace stx [expander expand/compile-time-evals]) + (let-values ([(result events derivp) (trace* stx expander)]) + (force derivp))) + +;; trace/result : stx -> stx/exn Deriv +(define (trace/result stx [expander expand/compile-time-evals]) + (let-values ([(result events derivp) (trace* stx expander)]) + (values result + (force derivp)))) + +;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv) +(define (trace* stx [expander expand/compile-time-evals]) + (let-values ([(result events) (expand/events stx expander)]) + (values result + events + (delay (parse-derivation + (events->token-generator events)))))) + +;; events->token-generator : (list-of event) -> (-> token) +(define (events->token-generator events) + (let ([pos 1]) + (lambda () + (define sig+val (car events)) + (set! events (cdr events)) + (let* ([sig (car sig+val)] + [val (cdr sig+val)] + [t (tokenize sig val pos)]) + (when (trace-verbose?) + (printf "~s: ~s~n" pos + (token-name (position-token-token t)))) + (set! pos (add1 pos)) + t)))) + +(define trace-macro-limit (make-parameter #f)) +(define trace-limit-handler (make-parameter #f)) + +;; expand/events : stx (stx -> stx) -> stx/exn (list-of event) +(define (expand/events sexpr expander) + (define events null) + (define counter 0) + (define (add! x y) + (set! events (cons (cons (signal->symbol x) y) events))) + (define add!/check + (let ([limit (trace-macro-limit)] + [handler (trace-limit-handler)]) + (if (and limit handler (exact-positive-integer? limit)) + (lambda (x y) + (add! x y) + (when (eqv? x 8) ;; enter-macro + (set! counter (add1 counter)) + (when (= counter limit) + (set! limit (handler counter))))) + add!))) + (parameterize ((current-expand-observe add!/check)) + (let ([result + (with-handlers ([(lambda (exn) #t) + (lambda (exn) + (add! 'error exn) + exn)]) + (expander sexpr))]) + (add! 'EOF #f) + (values result + (reverse events))))) + + +(require syntax/stx + syntax/kerncase) + +(define (emit sig [val #f]) + ((current-expand-observe) sig val)) + +(define (expand/compile-time-evals stx) + (define (expand/cte stx) + (define _ (emit 'visit stx)) + (define e1 (expand-syntax-to-top-form stx)) + (define e2 + (syntax-case e1 (begin) + [(begin expr ...) + (begin + (emit 'top-begin e1) + (with-syntax ([(expr ...) + ;;left-to-right part of this map is important: + (map (lambda (e) + (emit 'next) + (expand/cte e)) + (syntax->list #'(expr ...)))] + [beg (stx-car e1)]) + (datum->syntax e1 (syntax-e (syntax (beg expr ...))) e1 e1)))] + [else + (begin + (emit 'top-non-begin) + (let ([e (expand-syntax e1)]) + ;; Must set to void to avoid catching DrRacket's annotations... + (parameterize ((current-expand-observe void)) + (eval-compile-time-part e)) + e))])) + (emit 'return e2) + e2) + (emit 'start) + (expand/cte (namespace-syntax-introduce (datum->syntax #f stx)))) + +;; eval-compile-time-part : syntax boolean -> void +;; compiles the syntax it receives as an argument and evaluates the compile-time part of it. +;; pre: there are no top-level begins in stx. +(define (eval-compile-time-part stx) + (define (eval/compile stx) + (eval (compile-syntax stx))) + (kernel-syntax-case stx #f + [(#%require req ...) + (for ([req (syntax->list #'(req ...))]) + (namespace-require/expansion-time (syntax->datum req)))] + [(module . _) + (eval/compile stx)] + [(define-syntaxes . _) + (eval/compile stx)] + [(define-values-for-syntax . _) + (eval/compile stx)] + [(define-values (id ...) . _) + (with-syntax ([defvals (stx-car stx)] + [undefined (letrec ([x x]) x)]) + (for ([id (syntax->list #'(id ...))]) + (with-syntax ([id id]) + (eval/compile #'(defvals (id) undefined))))) + ;; Following doesn't work (namespace mismatch) + ;; (eval/compile #'(define-values (id ...) (let ([id #f] ...) (values id ...)))) + ] + [_else + (void)])) diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss @@ -1,153 +0,0 @@ - -#lang scheme/base -(require scheme/promise - parser-tools/lex - "deriv.ss" - "deriv-parser.ss" - "deriv-tokens.ss") - -(provide trace - trace* - trace/result - trace-verbose? - events->token-generator - current-expand-observe - expand/compile-time-evals - - trace-macro-limit - trace-limit-handler) - -(define current-expand-observe - (dynamic-require ''#%expobs 'current-expand-observe)) - -(define trace-verbose? (make-parameter #f)) - -;; trace : stx -> Deriv -(define (trace stx [expander expand/compile-time-evals]) - (let-values ([(result events derivp) (trace* stx expander)]) - (force derivp))) - -;; trace/result : stx -> stx/exn Deriv -(define (trace/result stx [expander expand/compile-time-evals]) - (let-values ([(result events derivp) (trace* stx expander)]) - (values result - (force derivp)))) - -;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv) -(define (trace* stx [expander expand/compile-time-evals]) - (let-values ([(result events) (expand/events stx expander)]) - (values result - events - (delay (parse-derivation - (events->token-generator events)))))) - -;; events->token-generator : (list-of event) -> (-> token) -(define (events->token-generator events) - (let ([pos 1]) - (lambda () - (define sig+val (car events)) - (set! events (cdr events)) - (let* ([sig (car sig+val)] - [val (cdr sig+val)] - [t (tokenize sig val pos)]) - (when (trace-verbose?) - (printf "~s: ~s~n" pos - (token-name (position-token-token t)))) - (set! pos (add1 pos)) - t)))) - -(define trace-macro-limit (make-parameter #f)) -(define trace-limit-handler (make-parameter #f)) - -;; expand/events : stx (stx -> stx) -> stx/exn (list-of event) -(define (expand/events sexpr expander) - (define events null) - (define counter 0) - (define (add! x y) - (set! events (cons (cons (signal->symbol x) y) events))) - (define add!/check - (let ([limit (trace-macro-limit)] - [handler (trace-limit-handler)]) - (if (and limit handler (exact-positive-integer? limit)) - (lambda (x y) - (add! x y) - (when (eqv? x 8) ;; enter-macro - (set! counter (add1 counter)) - (when (= counter limit) - (set! limit (handler counter))))) - add!))) - (parameterize ((current-expand-observe add!/check)) - (let ([result - (with-handlers ([(lambda (exn) #t) - (lambda (exn) - (add! 'error exn) - exn)]) - (expander sexpr))]) - (add! 'EOF #f) - (values result - (reverse events))))) - - -(require syntax/stx - syntax/kerncase) - -(define (emit sig [val #f]) - ((current-expand-observe) sig val)) - -(define (expand/compile-time-evals stx) - (define (expand/cte stx) - (define _ (emit 'visit stx)) - (define e1 (expand-syntax-to-top-form stx)) - (define e2 - (syntax-case e1 (begin) - [(begin expr ...) - (begin - (emit 'top-begin e1) - (with-syntax ([(expr ...) - ;;left-to-right part of this map is important: - (map (lambda (e) - (emit 'next) - (expand/cte e)) - (syntax->list #'(expr ...)))] - [beg (stx-car e1)]) - (datum->syntax e1 (syntax-e (syntax (beg expr ...))) e1 e1)))] - [else - (begin - (emit 'top-non-begin) - (let ([e (expand-syntax e1)]) - ;; Must set to void to avoid catching DrScheme's annotations... - (parameterize ((current-expand-observe void)) - (eval-compile-time-part e)) - e))])) - (emit 'return e2) - e2) - (emit 'start) - (expand/cte (namespace-syntax-introduce (datum->syntax #f stx)))) - -;; eval-compile-time-part : syntax boolean -> void -;; compiles the syntax it receives as an argument and evaluates the compile-time part of it. -;; pre: there are no top-level begins in stx. -(define (eval-compile-time-part stx) - (define (eval/compile stx) - (eval (compile-syntax stx))) - (kernel-syntax-case stx #f - [(#%require req ...) - (for ([req (syntax->list #'(req ...))]) - (namespace-require/expansion-time (syntax->datum req)))] - [(module . _) - (eval/compile stx)] - [(define-syntaxes . _) - (eval/compile stx)] - [(define-values-for-syntax . _) - (eval/compile stx)] - [(define-values (id ...) . _) - (with-syntax ([defvals (stx-car stx)] - [undefined (letrec ([x x]) x)]) - (for ([id (syntax->list #'(id ...))]) - (with-syntax ([id id]) - (eval/compile #'(defvals (id) undefined))))) - ;; Following doesn't work (namespace mismatch) - ;; (eval/compile #'(define-values (id ...) (let ([id #f] ...) (values id ...)))) - ] - [_else - (void)])) diff --git a/collects/macro-debugger/model/yacc-ext.ss b/collects/macro-debugger/model/yacc-ext.rkt diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.rkt diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.rkt diff --git a/collects/macro-debugger/stepper.ss b/collects/macro-debugger/stepper.rkt diff --git a/collects/macro-debugger/syntax-browser.ss b/collects/macro-debugger/syntax-browser.rkt diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.rkt diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt @@ -0,0 +1,296 @@ +#lang scheme/base +(require scheme/class + scheme/gui + scheme/list + (rename-in unstable/class-iop + [send/i send:] + [init-field/i init-field:]) + (only-in mzlib/etc begin-with-definitions) + "pretty-printer.ss" + "interfaces.ss" + "util.ss") +(provide print-syntax-to-editor + code-style) + +(define TIME-PRINTING? #f) + +(define-syntax-rule (now) + (if TIME-PRINTING? + (current-inexact-milliseconds) + 0)) + +;; FIXME: assumes text never moves + +;; print-syntax-to-editor : syntax text controller<%> config number number +;; -> display<%> +(define (print-syntax-to-editor stx text controller config columns + [insertion-point (send text last-position)]) + (begin-with-definitions + (define output-port (open-output-string/count-lines)) + (define range + (pretty-print-syntax stx output-port + (send: controller controller<%> get-primary-partition) + (length (send: config config<%> get-colors)) + (send: config config<%> get-suffix-option) + (send config get-pretty-styles) + columns)) + (define output-string (get-output-string output-port)) + (define output-length (sub1 (string-length output-string))) ;; skip final newline + (fixup-parentheses output-string range) + (send text begin-edit-sequence #f) + (send text insert output-length output-string insertion-point) + (define display + (new display% + (text text) + (controller controller) + (config config) + (range range) + (start-position insertion-point) + (end-position (+ insertion-point output-length)))) + (send display initialize) + (send text end-edit-sequence) + display)) + +;; display% +(define display% + (class* object% (display<%>) + (init-field: [controller controller<%>] + [config config<%>] + [range range<%>]) + (init-field text + start-position + end-position) + + (define base-style + (code-style text (send: config config<%> get-syntax-font-size))) + + (define extra-styles (make-hasheq)) + + ;; initialize : -> void + (define/public (initialize) + (send text change-style base-style start-position end-position #f) + (apply-primary-partition-styles) + (add-clickbacks) + (refresh)) + + ;; add-clickbacks : -> void + (define/private (add-clickbacks) + (define (the-clickback editor start end) + (send: controller selection-manager<%> set-selected-syntax + (clickback->stx + (- start start-position) (- end start-position)))) + (for ([range (send: range range<%> all-ranges)]) + (let ([stx (range-obj range)] + [start (range-start range)] + [end (range-end range)]) + (send text set-clickback (+ start-position start) (+ start-position end) + the-clickback)))) + + ;; clickback->stx : num num -> syntax + ;; FIXME: use vectors for treerange-subs and do binary search to narrow? + (define/private (clickback->stx start end) + (let ([treeranges (send: range range<%> get-treeranges)]) + (let loop* ([treeranges treeranges]) + (for/or ([tr treeranges]) + (cond [(and (= (treerange-start tr) start) + (= (treerange-end tr) end)) + (treerange-obj tr)] + [(and (<= (treerange-start tr) start) + (<= end (treerange-end tr))) + (loop* (treerange-subs tr))] + [else #f]))))) + + ;; refresh : -> void + ;; Clears all highlighting and reapplies all non-foreground styles. + (define/public (refresh) + (with-unlock text + (send* text + (begin-edit-sequence #f) + (change-style unhighlight-d start-position end-position)) + (apply-extra-styles) + (let ([selected-syntax + (send: controller selection-manager<%> + get-selected-syntax)]) + (apply-secondary-partition-styles selected-syntax) + (apply-selection-styles selected-syntax)) + (send* text + (end-edit-sequence)))) + + ;; get-range : -> range<%> + (define/public (get-range) range) + + ;; get-start-position : -> number + (define/public (get-start-position) start-position) + + ;; get-end-position : -> number + (define/public (get-end-position) end-position) + + ;; highlight-syntaxes : (list-of syntax) string -> void + (define/public (highlight-syntaxes stxs hi-color) + (let ([style-delta (highlight-style-delta hi-color #f)]) + (for ([stx stxs]) + (add-extra-styles stx (list style-delta)))) + (refresh)) + + ;; underline-syntaxes : (listof syntax) -> void + (define/public (underline-syntaxes stxs) + (for ([stx stxs]) + (add-extra-styles stx (list underline-style-delta))) + (refresh)) + + ;; add-extra-styles : syntax (listof style) -> void + (define/public (add-extra-styles stx styles) + (hash-set! extra-styles stx + (append (hash-ref extra-styles stx null) + styles))) + + ;; Primary styles + ;; (Done once on initialization, never repeated) + + ;; apply-primary-partition-styles : -> void + ;; Changes the foreground color according to the primary partition. + ;; Only called once, when the syntax is first drawn. + (define/private (apply-primary-partition-styles) + (define style-list (send text get-style-list)) + (define (color-style color) + (let ([delta (new style-delta%)]) + (send delta set-delta-foreground color) + (send style-list find-or-create-style base-style delta))) + (define color-styles + (list->vector (map color-style (send: config config<%> get-colors)))) + (define overflow-style (color-style "darkgray")) + (define color-partition + (send: controller mark-manager<%> get-primary-partition)) + (define offset start-position) + ;; Optimization: don't call change-style when new style = old style + (let tr*loop ([trs (send: range range<%> get-treeranges)] [old-style #f]) + (for ([tr trs]) + (define stx (treerange-obj tr)) + (define start (treerange-start tr)) + (define end (treerange-end tr)) + (define subs (treerange-subs tr)) + (define new-style + (primary-style stx color-partition color-styles overflow-style)) + (unless (eq? old-style new-style) + (send text change-style new-style (+ offset start) (+ offset end) #f)) + (tr*loop subs new-style))) + (void)) + + ;; primary-style : syntax partition (vector-of style-delta%) style-delta% + ;; -> style-delta% + (define/private (primary-style stx partition color-vector overflow) + (let ([n (send: partition partition<%> get-partition stx)]) + (cond [(< n (vector-length color-vector)) + (vector-ref color-vector n)] + [else + overflow]))) + + ;; Secondary Styling + ;; May change in response to user actions + + ;; apply-extra-styles : -> void + ;; Applies externally-added styles (such as highlighting) + (define/private (apply-extra-styles) + (for ([(stx style-deltas) extra-styles]) + (for ([r (send: range range<%> get-ranges stx)]) + (for ([style-delta style-deltas]) + (restyle-range r style-delta))))) + + ;; apply-secondary-partition-styles : selected-syntax -> void + ;; If the selected syntax is an identifier, then styles all identifiers + ;; in the same partition in blue. + (define/private (apply-secondary-partition-styles selected-syntax) + (when (identifier? selected-syntax) + (let ([partition + (send: controller secondary-partition<%> + get-secondary-partition)]) + (when partition + (for ([id (send: range range<%> get-identifier-list)]) + (when (send: partition partition<%> + same-partition? selected-syntax id) + (draw-secondary-connection id))))))) + + ;; apply-selection-styles : syntax -> void + ;; Styles subterms eq to the selected syntax + (define/private (apply-selection-styles selected-syntax) + (for ([r (send: range range<%> get-ranges selected-syntax)]) + (restyle-range r select-highlight-d))) + + ;; draw-secondary-connection : syntax -> void + (define/private (draw-secondary-connection stx2) + (for ([r (send: range range<%> get-ranges stx2)]) + (restyle-range r select-sub-highlight-d))) + + ;; restyle-range : (cons num num) style-delta% -> void + (define/private (restyle-range r style) + (send text change-style style + (relative->text-position (car r)) + (relative->text-position (cdr r)))) + + ;; relative->text-position : number -> number + (define/private (relative->text-position pos) + (+ pos start-position)) + + ;; Initialize + (super-new) + (send: controller controller<%> add-syntax-display this))) + +;; fixup-parentheses : string range -> void +(define (fixup-parentheses string range) + (for ([r (send: range range<%> all-ranges)]) + (let ([stx (range-obj r)] + [start (range-start r)] + [end (range-end r)]) + (when (and (syntax? stx) (pair? (syntax-e stx))) + (case (syntax-property stx 'paren-shape) + ((#\[) + (string-set! string start #\[) + (string-set! string (sub1 end) #\])) + ((#\{) + (string-set! string start #\{) + (string-set! string (sub1 end) #\}))))))) + +(define (open-output-string/count-lines) + (let ([os (open-output-string)]) + (port-count-lines! os) + os)) + +;; code-style : text<%> number/#f -> style<%> +(define (code-style text font-size) + (let* ([style-list (send text get-style-list)] + [style (send style-list find-named-style "Standard")]) + (if font-size + (send style-list find-or-create-style + style + (make-object style-delta% 'change-size font-size)) + style))) + +;; anchor-snip% +(define anchor-snip% + (class snip% + (define/override (copy) + (make-object string-snip% "")) + (super-instantiate ()))) + +;; Styles + +(define (highlight-style-delta color em?) + (let ([sd (new style-delta%)]) + (unless em? (send sd set-delta-background color)) + (when em? (send sd set-weight-on 'bold)) + (unless em? (send sd set-underlined-off #t) + (send sd set-weight-off 'bold)) + sd)) + +(define underline-style-delta + (let ([sd (new style-delta%)]) + (send sd set-underlined-on #t) + sd)) + +(define selection-color "yellow") +(define subselection-color "yellow") + +(define select-highlight-d (highlight-style-delta selection-color #t)) +(define select-sub-highlight-d (highlight-style-delta subselection-color #f)) + +(define unhighlight-d (highlight-style-delta "white" #f)) diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss @@ -1,302 +0,0 @@ -#lang scheme/base -(require scheme/class - scheme/gui - scheme/list - (rename-in unstable/class-iop - [send/i send:] - [init-field/i init-field:]) - (only-in mzlib/etc begin-with-definitions) - "pretty-printer.ss" - "interfaces.ss" - "util.ss") -(provide print-syntax-to-editor - code-style) - -(define TIME-PRINTING? #f) - -(define-syntax-rule (now) - (if TIME-PRINTING? - (current-inexact-milliseconds) - 0)) - -(define eprintf - (if TIME-PRINTING? - (let ([eport (current-error-port)]) - (lambda (fmt . args) (apply fprintf eport fmt args))) - void)) - -;; FIXME: assumes text never moves - -;; print-syntax-to-editor : syntax text controller<%> config number number -;; -> display<%> -(define (print-syntax-to-editor stx text controller config columns - [insertion-point (send text last-position)]) - (begin-with-definitions - (define output-port (open-output-string/count-lines)) - (define range - (pretty-print-syntax stx output-port - (send: controller controller<%> get-primary-partition) - (length (send: config config<%> get-colors)) - (send: config config<%> get-suffix-option) - (send config get-pretty-styles) - columns)) - (define output-string (get-output-string output-port)) - (define output-length (sub1 (string-length output-string))) ;; skip final newline - (fixup-parentheses output-string range) - (send text begin-edit-sequence #f) - (send text insert output-length output-string insertion-point) - (define display - (new display% - (text text) - (controller controller) - (config config) - (range range) - (start-position insertion-point) - (end-position (+ insertion-point output-length)))) - (send display initialize) - (send text end-edit-sequence) - display)) - -;; display% -(define display% - (class* object% (display<%>) - (init-field: [controller controller<%>] - [config config<%>] - [range range<%>]) - (init-field text - start-position - end-position) - - (define base-style - (code-style text (send: config config<%> get-syntax-font-size))) - - (define extra-styles (make-hasheq)) - - ;; initialize : -> void - (define/public (initialize) - (send text change-style base-style start-position end-position #f) - (apply-primary-partition-styles) - (add-clickbacks) - (refresh)) - - ;; add-clickbacks : -> void - (define/private (add-clickbacks) - (define (the-clickback editor start end) - (send: controller selection-manager<%> set-selected-syntax - (clickback->stx - (- start start-position) (- end start-position)))) - (for ([range (send: range range<%> all-ranges)]) - (let ([stx (range-obj range)] - [start (range-start range)] - [end (range-end range)]) - (send text set-clickback (+ start-position start) (+ start-position end) - the-clickback)))) - - ;; clickback->stx : num num -> syntax - ;; FIXME: use vectors for treerange-subs and do binary search to narrow? - (define/private (clickback->stx start end) - (let ([treeranges (send: range range<%> get-treeranges)]) - (let loop* ([treeranges treeranges]) - (for/or ([tr treeranges]) - (cond [(and (= (treerange-start tr) start) - (= (treerange-end tr) end)) - (treerange-obj tr)] - [(and (<= (treerange-start tr) start) - (<= end (treerange-end tr))) - (loop* (treerange-subs tr))] - [else #f]))))) - - ;; refresh : -> void - ;; Clears all highlighting and reapplies all non-foreground styles. - (define/public (refresh) - (with-unlock text - (send* text - (begin-edit-sequence #f) - (change-style unhighlight-d start-position end-position)) - (apply-extra-styles) - (let ([selected-syntax - (send: controller selection-manager<%> - get-selected-syntax)]) - (apply-secondary-partition-styles selected-syntax) - (apply-selection-styles selected-syntax)) - (send* text - (end-edit-sequence)))) - - ;; get-range : -> range<%> - (define/public (get-range) range) - - ;; get-start-position : -> number - (define/public (get-start-position) start-position) - - ;; get-end-position : -> number - (define/public (get-end-position) end-position) - - ;; highlight-syntaxes : (list-of syntax) string -> void - (define/public (highlight-syntaxes stxs hi-color) - (let ([style-delta (highlight-style-delta hi-color #f)]) - (for ([stx stxs]) - (add-extra-styles stx (list style-delta)))) - (refresh)) - - ;; underline-syntaxes : (listof syntax) -> void - (define/public (underline-syntaxes stxs) - (for ([stx stxs]) - (add-extra-styles stx (list underline-style-delta))) - (refresh)) - - ;; add-extra-styles : syntax (listof style) -> void - (define/public (add-extra-styles stx styles) - (hash-set! extra-styles stx - (append (hash-ref extra-styles stx null) - styles))) - - ;; Primary styles - ;; (Done once on initialization, never repeated) - - ;; apply-primary-partition-styles : -> void - ;; Changes the foreground color according to the primary partition. - ;; Only called once, when the syntax is first drawn. - (define/private (apply-primary-partition-styles) - (define style-list (send text get-style-list)) - (define (color-style color) - (let ([delta (new style-delta%)]) - (send delta set-delta-foreground color) - (send style-list find-or-create-style base-style delta))) - (define color-styles - (list->vector (map color-style (send: config config<%> get-colors)))) - (define overflow-style (color-style "darkgray")) - (define color-partition - (send: controller mark-manager<%> get-primary-partition)) - (define offset start-position) - ;; Optimization: don't call change-style when new style = old style - (let tr*loop ([trs (send: range range<%> get-treeranges)] [old-style #f]) - (for ([tr trs]) - (define stx (treerange-obj tr)) - (define start (treerange-start tr)) - (define end (treerange-end tr)) - (define subs (treerange-subs tr)) - (define new-style - (primary-style stx color-partition color-styles overflow-style)) - (unless (eq? old-style new-style) - (send text change-style new-style (+ offset start) (+ offset end) #f)) - (tr*loop subs new-style))) - (void)) - - ;; primary-style : syntax partition (vector-of style-delta%) style-delta% - ;; -> style-delta% - (define/private (primary-style stx partition color-vector overflow) - (let ([n (send: partition partition<%> get-partition stx)]) - (cond [(< n (vector-length color-vector)) - (vector-ref color-vector n)] - [else - overflow]))) - - ;; Secondary Styling - ;; May change in response to user actions - - ;; apply-extra-styles : -> void - ;; Applies externally-added styles (such as highlighting) - (define/private (apply-extra-styles) - (for ([(stx style-deltas) extra-styles]) - (for ([r (send: range range<%> get-ranges stx)]) - (for ([style-delta style-deltas]) - (restyle-range r style-delta))))) - - ;; apply-secondary-partition-styles : selected-syntax -> void - ;; If the selected syntax is an identifier, then styles all identifiers - ;; in the same partition in blue. - (define/private (apply-secondary-partition-styles selected-syntax) - (when (identifier? selected-syntax) - (let ([partition - (send: controller secondary-partition<%> - get-secondary-partition)]) - (when partition - (for ([id (send: range range<%> get-identifier-list)]) - (when (send: partition partition<%> - same-partition? selected-syntax id) - (draw-secondary-connection id))))))) - - ;; apply-selection-styles : syntax -> void - ;; Styles subterms eq to the selected syntax - (define/private (apply-selection-styles selected-syntax) - (for ([r (send: range range<%> get-ranges selected-syntax)]) - (restyle-range r select-highlight-d))) - - ;; draw-secondary-connection : syntax -> void - (define/private (draw-secondary-connection stx2) - (for ([r (send: range range<%> get-ranges stx2)]) - (restyle-range r select-sub-highlight-d))) - - ;; restyle-range : (cons num num) style-delta% -> void - (define/private (restyle-range r style) - (send text change-style style - (relative->text-position (car r)) - (relative->text-position (cdr r)))) - - ;; relative->text-position : number -> number - (define/private (relative->text-position pos) - (+ pos start-position)) - - ;; Initialize - (super-new) - (send: controller controller<%> add-syntax-display this))) - -;; fixup-parentheses : string range -> void -(define (fixup-parentheses string range) - (for ([r (send: range range<%> all-ranges)]) - (let ([stx (range-obj r)] - [start (range-start r)] - [end (range-end r)]) - (when (and (syntax? stx) (pair? (syntax-e stx))) - (case (syntax-property stx 'paren-shape) - ((#\[) - (string-set! string start #\[) - (string-set! string (sub1 end) #\])) - ((#\{) - (string-set! string start #\{) - (string-set! string (sub1 end) #\}))))))) - -(define (open-output-string/count-lines) - (let ([os (open-output-string)]) - (port-count-lines! os) - os)) - -;; code-style : text<%> number/#f -> style<%> -(define (code-style text font-size) - (let* ([style-list (send text get-style-list)] - [style (send style-list find-named-style "Standard")]) - (if font-size - (send style-list find-or-create-style - style - (make-object style-delta% 'change-size font-size)) - style))) - -;; anchor-snip% -(define anchor-snip% - (class snip% - (define/override (copy) - (make-object string-snip% "")) - (super-instantiate ()))) - -;; Styles - -(define (highlight-style-delta color em?) - (let ([sd (new style-delta%)]) - (unless em? (send sd set-delta-background color)) - (when em? (send sd set-weight-on 'bold)) - (unless em? (send sd set-underlined-off #t) - (send sd set-weight-off 'bold)) - sd)) - -(define underline-style-delta - (let ([sd (new style-delta%)]) - (send sd set-underlined-on #t) - sd)) - -(define selection-color "yellow") -(define subselection-color "yellow") - -(define select-highlight-d (highlight-style-delta selection-color #t)) -(define select-sub-highlight-d (highlight-style-delta subselection-color #f)) - -(define unhighlight-d (highlight-style-delta "white" #f)) diff --git a/collects/macro-debugger/syntax-browser/embed.ss b/collects/macro-debugger/syntax-browser/embed.rkt diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.rkt diff --git a/collects/macro-debugger/syntax-browser/hrule-snip.ss b/collects/macro-debugger/syntax-browser/hrule-snip.rkt diff --git a/collects/macro-debugger/syntax-browser/image.ss b/collects/macro-debugger/syntax-browser/image.rkt diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.rkt diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.rkt diff --git a/collects/macro-debugger/syntax-browser/partition.ss b/collects/macro-debugger/syntax-browser/partition.rkt diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.rkt diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.rkt diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.rkt diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.rkt diff --git a/collects/macro-debugger/syntax-browser/snip-decorated.ss b/collects/macro-debugger/syntax-browser/snip-decorated.rkt diff --git a/collects/macro-debugger/syntax-browser/snip.ss b/collects/macro-debugger/syntax-browser/snip.rkt diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt @@ -0,0 +1,329 @@ +#lang scheme/base +(require scheme/list + scheme/class + scheme/gui + drracket/arrow + framework/framework + unstable/interval-map + unstable/gui/notify + "interfaces.ss") + +(provide text:hover<%> + text:hover-drawings<%> + text:arrows<%> + + text:hover-mixin + text:hover-drawings-mixin + text:tacking-mixin + text:arrows-mixin) + +(define arrow-brush + (send the-brush-list find-or-create-brush "white" 'solid)) +(define (tacked-arrow-brush color) + (send the-brush-list find-or-create-brush color 'solid)) + +(define billboard-brush + (send the-brush-list find-or-create-brush "white" 'solid)) + +(define white (send the-color-database find-color "white")) + +;; A Drawing is (make-drawing number number (??? -> void) (box boolean)) +(define-struct drawing (start end draw tacked?)) + +(define-struct idloc (start end id)) + +(define (mean x y) + (/ (+ x y) 2)) + +(define-syntax with-saved-pen&brush + (syntax-rules () + [(with-saved-pen&brush dc . body) + (save-pen&brush dc (lambda () . body))])) + +(define (save-pen&brush dc thunk) + (let ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)]) + (begin0 (thunk) + (send dc set-pen old-pen) + (send dc set-brush old-brush)))) + +(define-syntax with-saved-text-config + (syntax-rules () + [(with-saved-text-config dc . body) + (save-text-config dc (lambda () . body))])) + +(define (save-text-config dc thunk) + (let ([old-font (send dc get-font)] + [old-color (send dc get-text-foreground)] + [old-background (send dc get-text-background)] + [old-mode (send dc get-text-mode)]) + (begin0 (thunk) + (send dc set-font old-font) + (send dc set-text-foreground old-color) + (send dc set-text-background old-background) + (send dc set-text-mode old-mode)))) + +(define text:hover<%> + (interface (text:basic<%>) + update-hover-position)) + +(define text:hover-drawings<%> + (interface (text:basic<%>) + add-hover-drawing + get-position-drawings + delete-all-drawings)) + +(define text:arrows<%> + (interface (text:hover-drawings<%>) + add-arrow + add-question-arrow + add-billboard)) + +(define text:hover-mixin + (mixin (text:basic<%>) (text:hover<%>) + (inherit dc-location-to-editor-location + find-position) + + (define/override (on-default-event ev) + (define gx (send ev get-x)) + (define gy (send ev get-y)) + (define-values (x y) (dc-location-to-editor-location gx gy)) + (define pos (find-position x y)) + (super on-default-event ev) + (case (send ev get-event-type) + ((enter motion leave) + (update-hover-position pos)))) + + (define/public (update-hover-position pos) + (void)) + + (super-new))) + +(define text:hover-drawings-mixin + (mixin (text:hover<%>) (text:hover-drawings<%>) + (inherit dc-location-to-editor-location + find-position + invalidate-bitmap-cache) + + ;; interval-map of Drawings + (define drawings-list (make-numeric-interval-map)) + + (field [hover-position #f]) + + (define/override (update-hover-position pos) + (define old-pos hover-position) + (super update-hover-position pos) + (set! hover-position pos) + (unless (same-drawings? old-pos pos) + (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))) + + (define/public (add-hover-drawing start end draw [tack-box (box #f)]) + (let ([drawing (make-drawing start end draw tack-box)]) + (interval-map-cons*! drawings-list + start (add1 end) + drawing + null))) + + (define/public (delete-all-drawings) + (interval-map-remove! drawings-list -inf.0 +inf.0)) + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (super on-paint before? dc left top right bottom dx dy draw-caret) + (unless before? + (for ([d (get-position-drawings hover-position)]) + ((drawing-draw d) this dc left top right bottom dx dy)))) + + (define/public (get-position-drawings pos) + (if pos (interval-map-ref drawings-list pos null) null)) + + (define/private (same-drawings? old-pos pos) + ;; relies on order drawings added & list-of-eq?-struct equality + (equal? (get-position-drawings old-pos) + (get-position-drawings pos))) + + (super-new))) + +(define text:tacking-mixin + (mixin (text:basic<%> text:hover-drawings<%>) () + (inherit get-canvas + get-keymap + get-position-drawings) + (inherit-field hover-position) + (super-new) + + (define tacked-table (make-hasheq)) + + (define/override (on-event ev) + (case (send ev get-event-type) + ((right-down) + (if (pair? (get-position-drawings hover-position)) + (send (get-canvas) popup-menu + (make-tack/untack-menu) + (send ev get-x) + (send ev get-y)) + (super on-event ev))) + (else + (super on-event ev)))) + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (super on-paint before? dc left top right bottom dx dy draw-caret) + (unless before? + (for ([draw (in-hash-keys tacked-table)]) + (draw this dc left top right bottom dx dy)))) + + (define/private (make-tack/untack-menu) + (define menu (new popup-menu%)) + (define keymap (get-keymap)) + (new menu-item% (label "Tack") + (parent menu) + (callback (lambda _ (tack)))) + (new menu-item% (label "Untack") + (parent menu) + (callback (lambda _ (untack)))) + (when (is-a? keymap keymap/popup<%>) + (new separator-menu-item% (parent menu)) + (send keymap add-context-menu-items menu)) + menu) + + (define/private (tack) + (for ([d (get-position-drawings hover-position)]) + (hash-set! tacked-table (drawing-draw d) #t) + (set-box! (drawing-tacked? d) #t))) + (define/private (untack) + (for ([d (get-position-drawings hover-position)]) + (hash-remove! tacked-table (drawing-draw d)) + (set-box! (drawing-tacked? d) #f))))) + +(define text:arrows-mixin + (mixin (text:hover-drawings<%>) (text:arrows<%>) + (inherit position-location + add-hover-drawing + find-wordbreak) + + (define/public (add-arrow from1 from2 to1 to2 color) + (internal-add-arrow from1 from2 to1 to2 color #f)) + + (define/public (add-question-arrow from1 from2 to1 to2 color) + (internal-add-arrow from1 from2 to1 to2 color #t)) + + (define/public (add-billboard pos1 pos2 str color-name) + (define color (send the-color-database find-color color-name)) + (let ([draw + (lambda (text dc left top right bottom dx dy) + (let-values ([(x y) (range->mean-loc pos1 pos1)] + [(fw fh _d _v) (send dc get-text-extent "y")]) + (with-saved-pen&brush dc + (with-saved-text-config dc + (send* dc + (set-pen color 1 'solid) + (set-brush billboard-brush) + (set-text-mode 'solid) + (set-font (billboard-font dc)) + (set-text-foreground color)) + (let-values ([(w h d v) (send dc get-text-extent str)] + [(adj-y) fh] + [(mini) _d]) + (send* dc + (draw-rounded-rectangle + (+ x dx) + (+ y dy adj-y) + (+ w mini mini) + (+ h mini mini)) + (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))]) + (add-hover-drawing pos1 pos2 draw))) + + (define/private (internal-add-arrow from1 from2 to1 to2 color-name question?) + (define color (send the-color-database find-color color-name)) + (define tack-box (box #f)) + (unless (and (= from1 to1) (= from2 to2)) + (let ([draw + (lambda (text dc left top right bottom dx dy) + (let-values ([(startx starty) (range->mean-loc from1 from2)] + [(endx endy) (range->mean-loc to1 to2)] + [(fw fh _d _v) (send dc get-text-extent "x")]) + (with-saved-pen&brush dc + (with-saved-text-config dc + (send dc set-pen color 1 'solid) + (send dc set-brush + (if (unbox tack-box) + (tacked-arrow-brush color) + arrow-brush)) + (draw-arrow dc startx + (+ starty (/ fh 2)) + endx + (+ endy (/ fh 2)) + dx dy) + (send dc set-text-mode 'transparent) + (when question? + (send dc set-font (?-font dc)) + (send dc set-text-foreground color) + (send dc draw-text "?" + (+ endx dx fw) + (- (+ endy dy) fh)))))))]) + (add-hover-drawing from1 from2 draw tack-box) + (add-hover-drawing to1 to2 draw tack-box)))) + + (define/private (position->location p) + (define xbox (box 0.0)) + (define ybox (box 0.0)) + (position-location p xbox ybox) + (values (unbox xbox) (unbox ybox))) + + (define/private (?-font dc) + (let ([size (send (send dc get-font) get-point-size)]) + (send the-font-list find-or-create-font size 'default 'normal 'bold))) + + (define/private (billboard-font dc) + (let ([size (send (send dc get-font) get-point-size)]) + (send the-font-list find-or-create-font size 'default 'normal))) + + (define/private (range->mean-loc pos1 pos2) + (let*-values ([(loc1x loc1y) (position->location pos1)] + [(loc2x loc2y) (position->location pos2)] + [(locx) (mean loc1x loc2x)] + [(locy) (mean loc1y loc2y)]) + (values locx locy))) + + (super-new))) + +(define text:hover-drawings% + (text:hover-drawings-mixin + (text:hover-mixin + text:standard-style-list%))) + +(define text:arrows% + (text:arrows-mixin + (text:tacking-mixin + text:hover-drawings%))) + + +#| +(define text:hover-identifier<%> + (interface () + get-hovered-identifier + set-hovered-identifier + listen-hovered-identifier)) + +(define text:hover-identifier-mixin + (mixin (text:hover<%>) (text:hover-identifier<%>) + (define-notify hovered-identifier (new notify-box% (value #f))) + + (define idlocs null) + + (define/public (add-identifier-location start end id) + (set! idlocs (cons (make-idloc start end id) idlocs))) + + (define/public (delete-all-identifier-locations) + (set! idlocs null) + (set-hovered-identifier #f)) + + (define/override (update-hover-position pos) + (super update-hover-position pos) + (let search ([idlocs idlocs]) + (cond [(null? idlocs) (set-hovered-identifier #f)] + [(and (<= (idloc-start (car idlocs)) pos) + (< pos (idloc-end (car idlocs)))) + (set-hovered-identifier (idloc-id (car idlocs)))] + [else (search (cdr idlocs))]))) + (super-new))) +|# diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss @@ -1,329 +0,0 @@ -#lang scheme/base -(require scheme/list - scheme/class - scheme/gui - drscheme/arrow - framework/framework - unstable/interval-map - unstable/gui/notify - "interfaces.ss") - -(provide text:hover<%> - text:hover-drawings<%> - text:arrows<%> - - text:hover-mixin - text:hover-drawings-mixin - text:tacking-mixin - text:arrows-mixin) - -(define arrow-brush - (send the-brush-list find-or-create-brush "white" 'solid)) -(define (tacked-arrow-brush color) - (send the-brush-list find-or-create-brush color 'solid)) - -(define billboard-brush - (send the-brush-list find-or-create-brush "white" 'solid)) - -(define white (send the-color-database find-color "white")) - -;; A Drawing is (make-drawing number number (??? -> void) (box boolean)) -(define-struct drawing (start end draw tacked?)) - -(define-struct idloc (start end id)) - -(define (mean x y) - (/ (+ x y) 2)) - -(define-syntax with-saved-pen&brush - (syntax-rules () - [(with-saved-pen&brush dc . body) - (save-pen&brush dc (lambda () . body))])) - -(define (save-pen&brush dc thunk) - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (begin0 (thunk) - (send dc set-pen old-pen) - (send dc set-brush old-brush)))) - -(define-syntax with-saved-text-config - (syntax-rules () - [(with-saved-text-config dc . body) - (save-text-config dc (lambda () . body))])) - -(define (save-text-config dc thunk) - (let ([old-font (send dc get-font)] - [old-color (send dc get-text-foreground)] - [old-background (send dc get-text-background)] - [old-mode (send dc get-text-mode)]) - (begin0 (thunk) - (send dc set-font old-font) - (send dc set-text-foreground old-color) - (send dc set-text-background old-background) - (send dc set-text-mode old-mode)))) - -(define text:hover<%> - (interface (text:basic<%>) - update-hover-position)) - -(define text:hover-drawings<%> - (interface (text:basic<%>) - add-hover-drawing - get-position-drawings - delete-all-drawings)) - -(define text:arrows<%> - (interface (text:hover-drawings<%>) - add-arrow - add-question-arrow - add-billboard)) - -(define text:hover-mixin - (mixin (text:basic<%>) (text:hover<%>) - (inherit dc-location-to-editor-location - find-position) - - (define/override (on-default-event ev) - (define gx (send ev get-x)) - (define gy (send ev get-y)) - (define-values (x y) (dc-location-to-editor-location gx gy)) - (define pos (find-position x y)) - (super on-default-event ev) - (case (send ev get-event-type) - ((enter motion leave) - (update-hover-position pos)))) - - (define/public (update-hover-position pos) - (void)) - - (super-new))) - -(define text:hover-drawings-mixin - (mixin (text:hover<%>) (text:hover-drawings<%>) - (inherit dc-location-to-editor-location - find-position - invalidate-bitmap-cache) - - ;; interval-map of Drawings - (define drawings-list (make-numeric-interval-map)) - - (field [hover-position #f]) - - (define/override (update-hover-position pos) - (define old-pos hover-position) - (super update-hover-position pos) - (set! hover-position pos) - (unless (same-drawings? old-pos pos) - (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))) - - (define/public (add-hover-drawing start end draw [tack-box (box #f)]) - (let ([drawing (make-drawing start end draw tack-box)]) - (interval-map-cons*! drawings-list - start (add1 end) - drawing - null))) - - (define/public (delete-all-drawings) - (interval-map-remove! drawings-list -inf.0 +inf.0)) - - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (super on-paint before? dc left top right bottom dx dy draw-caret) - (unless before? - (for ([d (get-position-drawings hover-position)]) - ((drawing-draw d) this dc left top right bottom dx dy)))) - - (define/public (get-position-drawings pos) - (if pos (interval-map-ref drawings-list pos null) null)) - - (define/private (same-drawings? old-pos pos) - ;; relies on order drawings added & list-of-eq?-struct equality - (equal? (get-position-drawings old-pos) - (get-position-drawings pos))) - - (super-new))) - -(define text:tacking-mixin - (mixin (text:basic<%> text:hover-drawings<%>) () - (inherit get-canvas - get-keymap - get-position-drawings) - (inherit-field hover-position) - (super-new) - - (define tacked-table (make-hasheq)) - - (define/override (on-event ev) - (case (send ev get-event-type) - ((right-down) - (if (pair? (get-position-drawings hover-position)) - (send (get-canvas) popup-menu - (make-tack/untack-menu) - (send ev get-x) - (send ev get-y)) - (super on-event ev))) - (else - (super on-event ev)))) - - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (super on-paint before? dc left top right bottom dx dy draw-caret) - (unless before? - (for ([draw (in-hash-keys tacked-table)]) - (draw this dc left top right bottom dx dy)))) - - (define/private (make-tack/untack-menu) - (define menu (new popup-menu%)) - (define keymap (get-keymap)) - (new menu-item% (label "Tack") - (parent menu) - (callback (lambda _ (tack)))) - (new menu-item% (label "Untack") - (parent menu) - (callback (lambda _ (untack)))) - (when (is-a? keymap keymap/popup<%>) - (new separator-menu-item% (parent menu)) - (send keymap add-context-menu-items menu)) - menu) - - (define/private (tack) - (for ([d (get-position-drawings hover-position)]) - (hash-set! tacked-table (drawing-draw d) #t) - (set-box! (drawing-tacked? d) #t))) - (define/private (untack) - (for ([d (get-position-drawings hover-position)]) - (hash-remove! tacked-table (drawing-draw d)) - (set-box! (drawing-tacked? d) #f))))) - -(define text:arrows-mixin - (mixin (text:hover-drawings<%>) (text:arrows<%>) - (inherit position-location - add-hover-drawing - find-wordbreak) - - (define/public (add-arrow from1 from2 to1 to2 color) - (internal-add-arrow from1 from2 to1 to2 color #f)) - - (define/public (add-question-arrow from1 from2 to1 to2 color) - (internal-add-arrow from1 from2 to1 to2 color #t)) - - (define/public (add-billboard pos1 pos2 str color-name) - (define color (send the-color-database find-color color-name)) - (let ([draw - (lambda (text dc left top right bottom dx dy) - (let-values ([(x y) (range->mean-loc pos1 pos1)] - [(fw fh _d _v) (send dc get-text-extent "y")]) - (with-saved-pen&brush dc - (with-saved-text-config dc - (send* dc - (set-pen color 1 'solid) - (set-brush billboard-brush) - (set-text-mode 'solid) - (set-font (billboard-font dc)) - (set-text-foreground color)) - (let-values ([(w h d v) (send dc get-text-extent str)] - [(adj-y) fh] - [(mini) _d]) - (send* dc - (draw-rounded-rectangle - (+ x dx) - (+ y dy adj-y) - (+ w mini mini) - (+ h mini mini)) - (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))]) - (add-hover-drawing pos1 pos2 draw))) - - (define/private (internal-add-arrow from1 from2 to1 to2 color-name question?) - (define color (send the-color-database find-color color-name)) - (define tack-box (box #f)) - (unless (and (= from1 to1) (= from2 to2)) - (let ([draw - (lambda (text dc left top right bottom dx dy) - (let-values ([(startx starty) (range->mean-loc from1 from2)] - [(endx endy) (range->mean-loc to1 to2)] - [(fw fh _d _v) (send dc get-text-extent "x")]) - (with-saved-pen&brush dc - (with-saved-text-config dc - (send dc set-pen color 1 'solid) - (send dc set-brush - (if (unbox tack-box) - (tacked-arrow-brush color) - arrow-brush)) - (draw-arrow dc startx - (+ starty (/ fh 2)) - endx - (+ endy (/ fh 2)) - dx dy) - (send dc set-text-mode 'transparent) - (when question? - (send dc set-font (?-font dc)) - (send dc set-text-foreground color) - (send dc draw-text "?" - (+ endx dx fw) - (- (+ endy dy) fh)))))))]) - (add-hover-drawing from1 from2 draw tack-box) - (add-hover-drawing to1 to2 draw tack-box)))) - - (define/private (position->location p) - (define xbox (box 0.0)) - (define ybox (box 0.0)) - (position-location p xbox ybox) - (values (unbox xbox) (unbox ybox))) - - (define/private (?-font dc) - (let ([size (send (send dc get-font) get-point-size)]) - (send the-font-list find-or-create-font size 'default 'normal 'bold))) - - (define/private (billboard-font dc) - (let ([size (send (send dc get-font) get-point-size)]) - (send the-font-list find-or-create-font size 'default 'normal))) - - (define/private (range->mean-loc pos1 pos2) - (let*-values ([(loc1x loc1y) (position->location pos1)] - [(loc2x loc2y) (position->location pos2)] - [(locx) (mean loc1x loc2x)] - [(locy) (mean loc1y loc2y)]) - (values locx locy))) - - (super-new))) - -(define text:hover-drawings% - (text:hover-drawings-mixin - (text:hover-mixin - text:standard-style-list%))) - -(define text:arrows% - (text:arrows-mixin - (text:tacking-mixin - text:hover-drawings%))) - - -#| -(define text:hover-identifier<%> - (interface () - get-hovered-identifier - set-hovered-identifier - listen-hovered-identifier)) - -(define text:hover-identifier-mixin - (mixin (text:hover<%>) (text:hover-identifier<%>) - (define-notify hovered-identifier (new notify-box% (value #f))) - - (define idlocs null) - - (define/public (add-identifier-location start end id) - (set! idlocs (cons (make-idloc start end id) idlocs))) - - (define/public (delete-all-identifier-locations) - (set! idlocs null) - (set-hovered-identifier #f)) - - (define/override (update-hover-position pos) - (super update-hover-position pos) - (let search ([idlocs idlocs]) - (cond [(null? idlocs) (set-hovered-identifier #f)] - [(and (<= (idloc-start (car idlocs)) pos) - (< pos (idloc-end (car idlocs)))) - (set-hovered-identifier (idloc-id (car idlocs)))] - [else (search (cdr idlocs))]))) - (super-new))) -|# diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.rkt diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.rkt diff --git a/collects/macro-debugger/util/mpi.ss b/collects/macro-debugger/util/mpi.rkt diff --git a/collects/macro-debugger/view/cursor.ss b/collects/macro-debugger/view/cursor.rkt diff --git a/collects/macro-debugger/view/debug-format.ss b/collects/macro-debugger/view/debug-format.rkt diff --git a/collects/macro-debugger/view/debug.ss b/collects/macro-debugger/view/debug.rkt diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.rkt diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.rkt diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.rkt diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.rkt diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.rkt diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.rkt diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.rkt diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.rkt diff --git a/collects/macro-debugger/view/view.ss b/collects/macro-debugger/view/view.rkt diff --git a/collects/tests/macro-debugger/all-tests.rkt b/collects/tests/macro-debugger/all-tests.rkt @@ -0,0 +1,42 @@ +#lang scheme/base +(require racunit + racunit/gui) +(require macro-debugger/model/debug + "gentest-framework.ss" + "gentests.ss" + "test-setup.ss" + "tests/syntax-basic.ss" + "tests/syntax-macros.ss" + "tests/syntax-modules.ss" + "tests/syntax-errors.ss" + "tests/hiding.ss" + "tests/regression.ss" + "tests/policy.ss" + "tests/collects.ss") +(provide go) + +(define (go) (test/gui all-tests)) +(define (collects) (test/gui big-libs-tests)) + +(define protos + (list proto:kernel-forms + proto:kernel-contexts + proto:macros + proto:modules + proto:errors)) + +(define deriv-test (mk-deriv-test protos)) +(define steps-test (mk-steps-test protos)) +(define hiding-deriv-test (mk-hidden-deriv-test protos)) +(define hiding-steps-test (mk-hidden-steps-test protos)) + +(define all-tests + (test-suite "All tests" + deriv-test + steps-test + hiding-deriv-test + hiding-steps-test + specialized-hiding-tests + regression-tests + #;seek-tests + policy-tests)) diff --git a/collects/tests/macro-debugger/all-tests.ss b/collects/tests/macro-debugger/all-tests.ss @@ -1,42 +0,0 @@ -#lang scheme/base -(require schemeunit - schemeunit/gui) -(require macro-debugger/model/debug - "gentest-framework.ss" - "gentests.ss" - "test-setup.ss" - "tests/syntax-basic.ss" - "tests/syntax-macros.ss" - "tests/syntax-modules.ss" - "tests/syntax-errors.ss" - "tests/hiding.ss" - "tests/regression.ss" - "tests/policy.ss" - "tests/collects.ss") -(provide go) - -(define (go) (test/gui all-tests)) -(define (collects) (test/gui big-libs-tests)) - -(define protos - (list proto:kernel-forms - proto:kernel-contexts - proto:macros - proto:modules - proto:errors)) - -(define deriv-test (mk-deriv-test protos)) -(define steps-test (mk-steps-test protos)) -(define hiding-deriv-test (mk-hidden-deriv-test protos)) -(define hiding-steps-test (mk-hidden-steps-test protos)) - -(define all-tests - (test-suite "All tests" - deriv-test - steps-test - hiding-deriv-test - hiding-steps-test - specialized-hiding-tests - regression-tests - #;seek-tests - policy-tests)) diff --git a/collects/tests/macro-debugger/gentest-framework.ss b/collects/tests/macro-debugger/gentest-framework.rkt diff --git a/collects/tests/macro-debugger/gentests.rkt b/collects/tests/macro-debugger/gentests.rkt @@ -0,0 +1,165 @@ +#lang scheme/base +(require racunit) +(require macro-debugger/model/debug + macro-debugger/model/stx-util + "gentest-framework.ss" + "test-setup.ss") +(provide mk-deriv-test + mk-steps-test + mk-hidden-deriv-test + mk-hidden-steps-test) + +(define (mk-deriv-test protos) + (mk-test "Derivations" checker-for-deriv protos)) + +(define (mk-steps-test protos) + (mk-test "Reductions" checker-for-steps protos)) + +(define (mk-hidden-deriv-test protos) + (mk-test "Hiding: Completes for multiple policies" + checker-for-hidden-deriv protos)) + +(define (mk-hidden-steps-test protos) + (mk-test "Hiding: Reductions" checker-for-hidden-steps protos)) + +(define (mk-test label checker protos) + (make-test-suite label + (filter values + (map (mk-gen-test checker) protos)))) + +(define (mk-gen-test f) + (define (gen prototest) + (match prototest + [(struct collection (label contents)) + (let ([tests (filter values (map gen contents))]) + (and (pair? tests) + (make-test-suite label tests)))] + [(struct individual (label form attrs)) + (f label form attrs)])) + gen) + +(define (checker-for-deriv label form attrs) + (cond [(assq '#:ok-deriv? attrs) + => (lambda (key+expect-ok?) + (test-case label + (let ([d (trace/ns form (assq '#:kernel attrs))]) + (check-pred deriv? d) + (if (cdr key+expect-ok?) + (check-pred ok-node? d) + (check-pred interrupted-node? d)))))] + [else #f])) + +(define (checker-for-hidden-deriv label form attrs) + (cond [(assq '#:ok-deriv? attrs) + => (lambda (key+expect-ok?) + (test-case label + (let ([d (trace/ns form (assq '#:kernel attrs))] + [expect-ok? (cdr key+expect-ok?)]) + (check-hide d hide-none-policy expect-ok?) + (check-hide d hide-all-policy expect-ok?) + (check-hide d T-policy expect-ok?))))] + [else #f])) + +(define (check-hide d policy expect-ok?) + (let-values ([(steps binders uses stx2 exn) + (parameterize ((macro-policy policy)) + (reductions+ d))]) + (check-pred list? steps) + (check-pred reduction-sequence? steps) + (check-true (not (and stx2 exn)) "Must not produce both estx and exn") + (if expect-ok? + (check-pred syntax? stx2 "Expected expanded syntax") + (check-pred exn? exn "Expected syntax error exn")))) + +(define (checker-for-steps label form attrs) + (cond [(assq '#:steps attrs) + => (lambda (key+expected) + (test-case label + (let* ([d (trace/ns form (assq '#:kernel attrs))] + [rs (reductions d)]) + (check-steps (cdr key+expected) rs))))] + [else #f])) + +(define (checker-for-hidden-steps label form attrs) + (cond [(assq '#:same-hidden-steps attrs) + (unless (assq '#:steps attrs) + (error 'checker-for-hidden-steps "no steps given for ~s" label)) + (test-case label + (let* ([d (trace/ns form (assq '#:kernel attrs))] + [rs (parameterize ((macro-policy T-policy)) + (reductions d))]) + (check-steps (cdr (assq '#:steps attrs)) rs)))] + [(assq '#:hidden-steps attrs) + => (lambda (key+expected) + (test-case label + (let* ([d (trace/ns form (assq '#:kernel attrs))] + [rs (parameterize ((macro-policy T-policy)) + (reductions d))]) + (check-steps (cdr (assq '#:hidden-steps attrs)) rs))))] + [else #f])) + +(define (check-steps expected actual) + (check-pred list? actual) + (check-pred reduction-sequence? actual) + (with-check-info (['actual-sequence-raw actual] + ['actual-sequence + (for/list ([thing actual]) + (if (misstep? thing) + 'error + (list* (protostep-type thing) + (syntax->datum (step-term2 thing)) + (map syntax->datum + (map bigframe-term (state-lctx (protostep-s1 thing)))))))] + ['expected-sequence expected]) + (compare-step-sequences actual expected))) + +(define (reduction-sequence? rs) + (andmap protostep? rs)) + +(define (compare-step-sequences actual expected) + (cond [(and (pair? expected) (pair? actual)) + (begin (compare-steps (car actual) (car expected)) + (compare-step-sequences (cdr actual) (cdr expected)))] + [(pair? expected) + (fail (format "missing expected steps:\n~s" expected))] + [(pair? actual) + (fail (format "too many steps:\n~a" + (apply append + (for/list ([step actual]) + (format "~s: ~s\n" + (protostep-type step) + (stx->datum (step-term2 step)))))))] + [else 'ok])) + +(define (compare-steps actual expected) + (cond [(eq? expected 'error) + (check-pred misstep? actual)] + [else + (let ([e-tag (car expected)] + [e-form (cadr expected)] + [e-locals (cddr expected)] + [lctx-terms (map bigframe-term (state-lctx (protostep-s1 actual)))]) + (check-pred step? actual) + (check-eq? (protostep-type actual) e-tag) + (check-equal-syntax? (syntax->datum (step-term2 actual)) + e-form) + (check-equal? (length lctx-terms) (length e-locals) + "Wrong number of context frames") + (for ([lctx-term lctx-terms] [e-local e-locals]) + (check-equal-syntax? (syntax->datum lctx-term) + e-local + "Context frame")))])) + +(define-binary-check (check-equal-syntax? a e) + (equal-syntax? a e)) + +(define (equal-syntax? a e) + (cond [(and (pair? a) (pair? e)) + (and (equal-syntax? (car a) (car e)) + (equal-syntax? (cdr a) (cdr e)))] + [(and (symbol? a) (symbol? e)) + (equal? (symbol->string a) + (symbol->string e))] + [(and (symbol? a) (regexp? e)) + (regexp-match? e (symbol->string a))] + [else (equal? a e)])) diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss @@ -1,165 +0,0 @@ -#lang scheme/base -(require schemeunit) -(require macro-debugger/model/debug - macro-debugger/model/stx-util - "gentest-framework.ss" - "test-setup.ss") -(provide mk-deriv-test - mk-steps-test - mk-hidden-deriv-test - mk-hidden-steps-test) - -(define (mk-deriv-test protos) - (mk-test "Derivations" checker-for-deriv protos)) - -(define (mk-steps-test protos) - (mk-test "Reductions" checker-for-steps protos)) - -(define (mk-hidden-deriv-test protos) - (mk-test "Hiding: Completes for multiple policies" - checker-for-hidden-deriv protos)) - -(define (mk-hidden-steps-test protos) - (mk-test "Hiding: Reductions" checker-for-hidden-steps protos)) - -(define (mk-test label checker protos) - (make-test-suite label - (filter values - (map (mk-gen-test checker) protos)))) - -(define (mk-gen-test f) - (define (gen prototest) - (match prototest - [(struct collection (label contents)) - (let ([tests (filter values (map gen contents))]) - (and (pair? tests) - (make-test-suite label tests)))] - [(struct individual (label form attrs)) - (f label form attrs)])) - gen) - -(define (checker-for-deriv label form attrs) - (cond [(assq '#:ok-deriv? attrs) - => (lambda (key+expect-ok?) - (test-case label - (let ([d (trace/ns form (assq '#:kernel attrs))]) - (check-pred deriv? d) - (if (cdr key+expect-ok?) - (check-pred ok-node? d) - (check-pred interrupted-node? d)))))] - [else #f])) - -(define (checker-for-hidden-deriv label form attrs) - (cond [(assq '#:ok-deriv? attrs) - => (lambda (key+expect-ok?) - (test-case label - (let ([d (trace/ns form (assq '#:kernel attrs))] - [expect-ok? (cdr key+expect-ok?)]) - (check-hide d hide-none-policy expect-ok?) - (check-hide d hide-all-policy expect-ok?) - (check-hide d T-policy expect-ok?))))] - [else #f])) - -(define (check-hide d policy expect-ok?) - (let-values ([(steps binders uses stx2 exn) - (parameterize ((macro-policy policy)) - (reductions+ d))]) - (check-pred list? steps) - (check-pred reduction-sequence? steps) - (check-true (not (and stx2 exn)) "Must not produce both estx and exn") - (if expect-ok? - (check-pred syntax? stx2 "Expected expanded syntax") - (check-pred exn? exn "Expected syntax error exn")))) - -(define (checker-for-steps label form attrs) - (cond [(assq '#:steps attrs) - => (lambda (key+expected) - (test-case label - (let* ([d (trace/ns form (assq '#:kernel attrs))] - [rs (reductions d)]) - (check-steps (cdr key+expected) rs))))] - [else #f])) - -(define (checker-for-hidden-steps label form attrs) - (cond [(assq '#:same-hidden-steps attrs) - (unless (assq '#:steps attrs) - (error 'checker-for-hidden-steps "no steps given for ~s" label)) - (test-case label - (let* ([d (trace/ns form (assq '#:kernel attrs))] - [rs (parameterize ((macro-policy T-policy)) - (reductions d))]) - (check-steps (cdr (assq '#:steps attrs)) rs)))] - [(assq '#:hidden-steps attrs) - => (lambda (key+expected) - (test-case label - (let* ([d (trace/ns form (assq '#:kernel attrs))] - [rs (parameterize ((macro-policy T-policy)) - (reductions d))]) - (check-steps (cdr (assq '#:hidden-steps attrs)) rs))))] - [else #f])) - -(define (check-steps expected actual) - (check-pred list? actual) - (check-pred reduction-sequence? actual) - (with-check-info (['actual-sequence-raw actual] - ['actual-sequence - (for/list ([thing actual]) - (if (misstep? thing) - 'error - (list* (protostep-type thing) - (syntax->datum (step-term2 thing)) - (map syntax->datum - (map bigframe-term (state-lctx (protostep-s1 thing)))))))] - ['expected-sequence expected]) - (compare-step-sequences actual expected))) - -(define (reduction-sequence? rs) - (andmap protostep? rs)) - -(define (compare-step-sequences actual expected) - (cond [(and (pair? expected) (pair? actual)) - (begin (compare-steps (car actual) (car expected)) - (compare-step-sequences (cdr actual) (cdr expected)))] - [(pair? expected) - (fail (format "missing expected steps:\n~s" expected))] - [(pair? actual) - (fail (format "too many steps:\n~a" - (apply append - (for/list ([step actual]) - (format "~s: ~s\n" - (protostep-type step) - (stx->datum (step-term2 step)))))))] - [else 'ok])) - -(define (compare-steps actual expected) - (cond [(eq? expected 'error) - (check-pred misstep? actual)] - [else - (let ([e-tag (car expected)] - [e-form (cadr expected)] - [e-locals (cddr expected)] - [lctx-terms (map bigframe-term (state-lctx (protostep-s1 actual)))]) - (check-pred step? actual) - (check-eq? (protostep-type actual) e-tag) - (check-equal-syntax? (syntax->datum (step-term2 actual)) - e-form) - (check-equal? (length lctx-terms) (length e-locals) - "Wrong number of context frames") - (for ([lctx-term lctx-terms] [e-local e-locals]) - (check-equal-syntax? (syntax->datum lctx-term) - e-local - "Context frame")))])) - -(define-binary-check (check-equal-syntax? a e) - (equal-syntax? a e)) - -(define (equal-syntax? a e) - (cond [(and (pair? a) (pair? e)) - (and (equal-syntax? (car a) (car e)) - (equal-syntax? (cdr a) (cdr e)))] - [(and (symbol? a) (symbol? e)) - (equal? (symbol->string a) - (symbol->string e))] - [(and (symbol? a) (regexp? e)) - (regexp-match? e (symbol->string a))] - [else (equal? a e)])) diff --git a/collects/tests/macro-debugger/gui-tests.ss b/collects/tests/macro-debugger/gui-tests.rkt diff --git a/collects/tests/macro-debugger/test-setup.ss b/collects/tests/macro-debugger/test-setup.rkt diff --git a/collects/tests/macro-debugger/tests/collects.rkt b/collects/tests/macro-debugger/tests/collects.rkt @@ -0,0 +1,326 @@ +#lang scheme/base +(require racunit + racunit/gui) +(require macro-debugger/model/debug + scheme/path + scheme/gui) +(provide big-libs-tests + loadlib + loadfile + trace-modules) + +;; loadlib : module-path symbol -> Deriv +(define (loadlib mod) + (let ([resolved ((current-module-name-resolver) mod #f #f #f)]) + (loadfile (resolved-module-path-name resolved)))) + +;; loadfile : path symbol -> Deriv +(define (loadfile path) + (define-values (base file dir?) (split-path path)) + (define expect-module + (string->symbol (path->string (path-replace-suffix file #"")))) + (define-values (eh mnr) + (make-handlers (current-eval) + (current-module-name-resolver))) + #;(printf "Loading ~s\n" (path->string path)) + #;(printf "Expecting module named '~s'\n" expect-module) + (parameterize ((current-load-relative-directory base) + (current-directory base) + (current-eval eh) + (current-module-name-resolver mnr)) + (let-values ([(e-expr deriv) + ((current-load) path expect-module)]) + (when (exn? e-expr) + (raise e-expr)) + deriv))) + +(define (make-handlers original-eval-handler original-module-name-resolver) + (values + (lambda (expr) + (unless (syntax? expr) + (raise-type-error 'eval-handler "syntax" expr)) + (trace/result expr)) + (lambda args + (parameterize ((current-eval original-eval-handler) + (current-module-name-resolver original-module-name-resolver)) + (apply original-module-name-resolver args))))) + +(define (test-libs name mods) + (test-suite name + (apply make-test-suite "Trace & Parse" + (for/list ([m mods]) (test-lib/deriv m))) + (apply make-test-suite "Reductions" + (for/list ([m mods]) (test-lib/hide m hide-none-policy))) + (apply make-test-suite "Standard hiding" + (for/list ([m mods]) (test-lib/hide m standard-policy))))) + +(define (test-lib/deriv m) + (test-case (format "~s" m) + (let ([deriv (loadlib m)]) + (check-pred deriv? deriv "Not a deriv") + (check-pred ok-node? deriv "Expansion error")))) + +(define (test-lib/hide m policy) + (test-case (format "~s" m) + (let ([deriv (loadlib m)]) + (check-steps deriv policy)))) + +(define (check-steps deriv policy) + (define-values (steps binders uses stx exn) + (parameterize ((macro-policy policy)) (reductions+ deriv))) + (check-pred syntax? stx) + (check-eq? exn #f) + (check-true (list? steps) "Expected list for steps") + (check-reduction-sequence steps)) + +(define (check-reduction-sequence steps) + (cond [(null? steps) (void)] + [(and (pair? steps) (step? (car steps))) + (check-reduction-sequence (cdr steps))] + [(and (pair? steps) (misstep? (car steps))) + (check-eq? (cdr steps) '() "Stuff after misstep")] + [else (fail "Bad reduction sequence")])) + +(define (make-tracing-module-name-resolver omnr table) + (case-lambda + [(mod rel stx load?) + (when load? + (when (not rel) + (hash-set! table mod #t)) + (when rel + (let ([abs (rel+mod->mod rel mod)]) + (when abs (hash-set! table abs #t))))) + (omnr mod rel stx load?)] + [args + (apply omnr args)])) + +(define (rel+mod->mod rel mod) + (define-values (base file dir?) (split-path (resolved-module-path-name rel))) + (path->mod (simplify-path (build-path base mod)))) + +(define (path->mod path) + (cond [(for/or ([c (current-library-collection-paths)]) (path->mod* path c)) + => (lambda (l) + (string->symbol + (path->string + (path-replace-suffix (apply build-path l) #""))))] + [else #f])) + +(define (path->mod* path base) + (let loop ([path (explode-path path)] [base (explode-path base)]) + (cond [(null? base) path] + [(and (pair? path) (pair? base) (equal? (car path) (car base))) + (loop (cdr path) (cdr base))] + [else #f]))) + +(define (trace-modules mods) + (define table (make-hash)) + (parameterize ((current-module-name-resolver + (make-tracing-module-name-resolver + (current-module-name-resolver) + table)) + (current-namespace (make-gui-namespace))) + (for ([mod mods]) + (dynamic-require mod #f)) + (let* ([loaded + (hash-map table (lambda (k v) k))] + [syms + (for/list ([l loaded] #:when (symbol? l)) l)] + [libs + (for/list ([l loaded] #:when (and (pair? l) (eq? (car l) 'lib))) l)] + [conv-libs + (for/list ([l libs]) + (string->symbol + (string-append + (apply string-append + (for/list ([d (cddr l)]) (string-append d "/"))) + (path->string (path-replace-suffix (cadr l) #"")))))]) + (sort (append syms conv-libs) + string<? + #:key symbol->string + #:cache-keys? #t)))) + +(define modules-from-framework (trace-modules '(framework))) +(define modules-from-typed-scheme + #;(trace-modules '(typed-scheme)) + '(#| + mzlib/contract + mzlib/etc + mzlib/file + mzlib/kw + mzlib/list + mzlib/match + mzlib/class + mzlib/cm-accomplice + mzlib/contract + mzlib/etc + mzlib/kw + mzlib/list + mzlib/pconvert + mzlib/pconvert-prop + mzlib/plt-match + mzlib/pretty + mzlib/private/increader + mzlib/private/unit-compiletime + mzlib/private/unit-keywords + mzlib/private/unit-runtime + mzlib/private/unit-syntax + mzlib/shared + mzlib/string + mzlib/struct + mzlib/trace + mzlib/unit + mzlib/unit-exptime + mzscheme + mzlib/plt-match + scheme/base + scheme/class + scheme/contract + scheme/include + scheme/list + scheme/match + scheme/match/compiler + scheme/match/define-forms + scheme/match/gen-match + scheme/match/legacy-match + scheme/match/match + scheme/match/match-expander + scheme/match/parse + scheme/match/parse-helper + scheme/match/parse-legacy + scheme/match/parse-quasi + scheme/match/patterns + scheme/match/reorder + scheme/match/split-rows + scheme/mzscheme + scheme/nest + scheme/private/class-internal + scheme/contract/private/base + scheme/contract/private/arrow + scheme/contract/private/basic-opters + scheme/contract/private/ds + scheme/contract/private/ds-helpers + scheme/contract/private/exists + scheme/contract/private/guts + scheme/contract/private/helpers + scheme/contract/private/misc + scheme/contract/private/opt + scheme/contract/private/opt-guts + scheme/private/define-struct + scheme/private/define-struct + scheme/private/for + scheme/private/kw + scheme/private/letstx-scheme + scheme/private/list + scheme/private/misc + scheme/private/modbeg + scheme/private/more-scheme + scheme/private/namespace + scheme/private/old-procs + scheme/private/pre-base + scheme/private/qqstx + scheme/private/reqprov + scheme/private/struct-info + scheme/private/stx + scheme/private/stxcase + scheme/private/stxcase-scheme + scheme/private/stxloc + scheme/private/stxparamkey + scheme/private/with-stx + scheme/promise + scheme/provide-transform + scheme/require-syntax + scheme/require-transform + scheme/struct-info + scheme/struct-info + scheme/stxparam + scheme/unit + scheme/unit-exptime + scheme/unit/lang + srfi/1 + srfi/1/alist + srfi/1/cons + srfi/1/delete + srfi/1/filter + srfi/1/fold + srfi/1/list + srfi/1/lset + srfi/1/misc + srfi/1/predicate + srfi/1/search + srfi/1/selector + srfi/1/util + srfi/optional + srfi/provider + mzlib/struct + syntax/boundmap + syntax/boundmap + syntax/context + syntax/free-vars + syntax/kerncase + syntax/kerncase + syntax/name + syntax/path-spec + syntax/private/boundmap + syntax/struct + syntax/struct + syntax/stx + syntax/stx + mzlib/trace + |# + typed-scheme + typed-scheme/minimal + typed-scheme/private/base-env + typed-scheme/private/base-types + typed-scheme/private/check-subforms-unit + typed-scheme/private/def-binding + typed-scheme/private/effect-rep + typed-scheme/private/extra-procs + typed-scheme/private/free-variance + typed-scheme/private/infer + typed-scheme/private/infer-ops + typed-scheme/private/init-envs + typed-scheme/private/internal-forms + typed-scheme/private/interning + typed-scheme/private/lexical-env + typed-scheme/private/mutated-vars + typed-scheme/private/parse-type + typed-scheme/private/planet-requires + typed-scheme/private/prims + typed-scheme/private/provide-handling + typed-scheme/private/remove-intersect + typed-scheme/private/rep-utils + typed-scheme/private/require-contract + typed-scheme/private/resolve-type + typed-scheme/private/signatures + typed-scheme/private/subtype + typed-scheme/private/syntax-traversal + typed-scheme/private/tables + typed-scheme/private/tc-app-unit + typed-scheme/private/tc-expr-unit + typed-scheme/private/tc-if-unit + typed-scheme/private/tc-lambda-unit + typed-scheme/private/tc-let-unit + typed-scheme/private/tc-structs + typed-scheme/private/tc-toplevel + typed-scheme/private/tc-utils + typed-scheme/private/type-alias-env + typed-scheme/private/type-annotation + typed-scheme/private/type-comparison + typed-scheme/private/type-contract + typed-scheme/private/type-effect-convenience + typed-scheme/private/type-effect-printer + typed-scheme/private/type-env + typed-scheme/private/type-environments + typed-scheme/private/type-name-env + typed-scheme/private/type-rep + typed-scheme/private/type-utils + typed-scheme/private/typechecker + typed-scheme/private/unify + typed-scheme/private/union + typed-scheme/private/unit-utils + typed-scheme/private/utils + typed-scheme/typed-scheme)) + +(define big-libs-tests + (test-libs "Collections" modules-from-typed-scheme)) diff --git a/collects/tests/macro-debugger/tests/collects.ss b/collects/tests/macro-debugger/tests/collects.ss @@ -1,326 +0,0 @@ -#lang scheme/base -(require schemeunit - schemeunit/gui) -(require macro-debugger/model/debug - scheme/path - scheme/gui) -(provide big-libs-tests - loadlib - loadfile - trace-modules) - -;; loadlib : module-path symbol -> Deriv -(define (loadlib mod) - (let ([resolved ((current-module-name-resolver) mod #f #f #f)]) - (loadfile (resolved-module-path-name resolved)))) - -;; loadfile : path symbol -> Deriv -(define (loadfile path) - (define-values (base file dir?) (split-path path)) - (define expect-module - (string->symbol (path->string (path-replace-suffix file #"")))) - (define-values (eh mnr) - (make-handlers (current-eval) - (current-module-name-resolver))) - #;(printf "Loading ~s\n" (path->string path)) - #;(printf "Expecting module named '~s'\n" expect-module) - (parameterize ((current-load-relative-directory base) - (current-directory base) - (current-eval eh) - (current-module-name-resolver mnr)) - (let-values ([(e-expr deriv) - ((current-load) path expect-module)]) - (when (exn? e-expr) - (raise e-expr)) - deriv))) - -(define (make-handlers original-eval-handler original-module-name-resolver) - (values - (lambda (expr) - (unless (syntax? expr) - (raise-type-error 'eval-handler "syntax" expr)) - (trace/result expr)) - (lambda args - (parameterize ((current-eval original-eval-handler) - (current-module-name-resolver original-module-name-resolver)) - (apply original-module-name-resolver args))))) - -(define (test-libs name mods) - (test-suite name - (apply make-test-suite "Trace & Parse" - (for/list ([m mods]) (test-lib/deriv m))) - (apply make-test-suite "Reductions" - (for/list ([m mods]) (test-lib/hide m hide-none-policy))) - (apply make-test-suite "Standard hiding" - (for/list ([m mods]) (test-lib/hide m standard-policy))))) - -(define (test-lib/deriv m) - (test-case (format "~s" m) - (let ([deriv (loadlib m)]) - (check-pred deriv? deriv "Not a deriv") - (check-pred ok-node? deriv "Expansion error")))) - -(define (test-lib/hide m policy) - (test-case (format "~s" m) - (let ([deriv (loadlib m)]) - (check-steps deriv policy)))) - -(define (check-steps deriv policy) - (define-values (steps binders uses stx exn) - (parameterize ((macro-policy policy)) (reductions+ deriv))) - (check-pred syntax? stx) - (check-eq? exn #f) - (check-true (list? steps) "Expected list for steps") - (check-reduction-sequence steps)) - -(define (check-reduction-sequence steps) - (cond [(null? steps) (void)] - [(and (pair? steps) (step? (car steps))) - (check-reduction-sequence (cdr steps))] - [(and (pair? steps) (misstep? (car steps))) - (check-eq? (cdr steps) '() "Stuff after misstep")] - [else (fail "Bad reduction sequence")])) - -(define (make-tracing-module-name-resolver omnr table) - (case-lambda - [(mod rel stx load?) - (when load? - (when (not rel) - (hash-set! table mod #t)) - (when rel - (let ([abs (rel+mod->mod rel mod)]) - (when abs (hash-set! table abs #t))))) - (omnr mod rel stx load?)] - [args - (apply omnr args)])) - -(define (rel+mod->mod rel mod) - (define-values (base file dir?) (split-path (resolved-module-path-name rel))) - (path->mod (simplify-path (build-path base mod)))) - -(define (path->mod path) - (cond [(for/or ([c (current-library-collection-paths)]) (path->mod* path c)) - => (lambda (l) - (string->symbol - (path->string - (path-replace-suffix (apply build-path l) #""))))] - [else #f])) - -(define (path->mod* path base) - (let loop ([path (explode-path path)] [base (explode-path base)]) - (cond [(null? base) path] - [(and (pair? path) (pair? base) (equal? (car path) (car base))) - (loop (cdr path) (cdr base))] - [else #f]))) - -(define (trace-modules mods) - (define table (make-hash)) - (parameterize ((current-module-name-resolver - (make-tracing-module-name-resolver - (current-module-name-resolver) - table)) - (current-namespace (make-gui-namespace))) - (for ([mod mods]) - (dynamic-require mod #f)) - (let* ([loaded - (hash-map table (lambda (k v) k))] - [syms - (for/list ([l loaded] #:when (symbol? l)) l)] - [libs - (for/list ([l loaded] #:when (and (pair? l) (eq? (car l) 'lib))) l)] - [conv-libs - (for/list ([l libs]) - (string->symbol - (string-append - (apply string-append - (for/list ([d (cddr l)]) (string-append d "/"))) - (path->string (path-replace-suffix (cadr l) #"")))))]) - (sort (append syms conv-libs) - string<? - #:key symbol->string - #:cache-keys? #t)))) - -(define modules-from-framework (trace-modules '(framework))) -(define modules-from-typed-scheme - #;(trace-modules '(typed-scheme)) - '(#| - mzlib/contract - mzlib/etc - mzlib/file - mzlib/kw - mzlib/list - mzlib/match - mzlib/class - mzlib/cm-accomplice - mzlib/contract - mzlib/etc - mzlib/kw - mzlib/list - mzlib/pconvert - mzlib/pconvert-prop - mzlib/plt-match - mzlib/pretty - mzlib/private/increader - mzlib/private/unit-compiletime - mzlib/private/unit-keywords - mzlib/private/unit-runtime - mzlib/private/unit-syntax - mzlib/shared - mzlib/string - mzlib/struct - mzlib/trace - mzlib/unit - mzlib/unit-exptime - mzscheme - mzlib/plt-match - scheme/base - scheme/class - scheme/contract - scheme/include - scheme/list - scheme/match - scheme/match/compiler - scheme/match/define-forms - scheme/match/gen-match - scheme/match/legacy-match - scheme/match/match - scheme/match/match-expander - scheme/match/parse - scheme/match/parse-helper - scheme/match/parse-legacy - scheme/match/parse-quasi - scheme/match/patterns - scheme/match/reorder - scheme/match/split-rows - scheme/mzscheme - scheme/nest - scheme/private/class-internal - scheme/contract/private/base - scheme/contract/private/arrow - scheme/contract/private/basic-opters - scheme/contract/private/ds - scheme/contract/private/ds-helpers - scheme/contract/private/exists - scheme/contract/private/guts - scheme/contract/private/helpers - scheme/contract/private/misc - scheme/contract/private/opt - scheme/contract/private/opt-guts - scheme/private/define-struct - scheme/private/define-struct - scheme/private/for - scheme/private/kw - scheme/private/letstx-scheme - scheme/private/list - scheme/private/misc - scheme/private/modbeg - scheme/private/more-scheme - scheme/private/namespace - scheme/private/old-procs - scheme/private/pre-base - scheme/private/qqstx - scheme/private/reqprov - scheme/private/struct-info - scheme/private/stx - scheme/private/stxcase - scheme/private/stxcase-scheme - scheme/private/stxloc - scheme/private/stxparamkey - scheme/private/with-stx - scheme/promise - scheme/provide-transform - scheme/require-syntax - scheme/require-transform - scheme/struct-info - scheme/struct-info - scheme/stxparam - scheme/unit - scheme/unit-exptime - scheme/unit/lang - srfi/1 - srfi/1/alist - srfi/1/cons - srfi/1/delete - srfi/1/filter - srfi/1/fold - srfi/1/list - srfi/1/lset - srfi/1/misc - srfi/1/predicate - srfi/1/search - srfi/1/selector - srfi/1/util - srfi/optional - srfi/provider - mzlib/struct - syntax/boundmap - syntax/boundmap - syntax/context - syntax/free-vars - syntax/kerncase - syntax/kerncase - syntax/name - syntax/path-spec - syntax/private/boundmap - syntax/struct - syntax/struct - syntax/stx - syntax/stx - mzlib/trace - |# - typed-scheme - typed-scheme/minimal - typed-scheme/private/base-env - typed-scheme/private/base-types - typed-scheme/private/check-subforms-unit - typed-scheme/private/def-binding - typed-scheme/private/effect-rep - typed-scheme/private/extra-procs - typed-scheme/private/free-variance - typed-scheme/private/infer - typed-scheme/private/infer-ops - typed-scheme/private/init-envs - typed-scheme/private/internal-forms - typed-scheme/private/interning - typed-scheme/private/lexical-env - typed-scheme/private/mutated-vars - typed-scheme/private/parse-type - typed-scheme/private/planet-requires - typed-scheme/private/prims - typed-scheme/private/provide-handling - typed-scheme/private/remove-intersect - typed-scheme/private/rep-utils - typed-scheme/private/require-contract - typed-scheme/private/resolve-type - typed-scheme/private/signatures - typed-scheme/private/subtype - typed-scheme/private/syntax-traversal - typed-scheme/private/tables - typed-scheme/private/tc-app-unit - typed-scheme/private/tc-expr-unit - typed-scheme/private/tc-if-unit - typed-scheme/private/tc-lambda-unit - typed-scheme/private/tc-let-unit - typed-scheme/private/tc-structs - typed-scheme/private/tc-toplevel - typed-scheme/private/tc-utils - typed-scheme/private/type-alias-env - typed-scheme/private/type-annotation - typed-scheme/private/type-comparison - typed-scheme/private/type-contract - typed-scheme/private/type-effect-convenience - typed-scheme/private/type-effect-printer - typed-scheme/private/type-env - typed-scheme/private/type-environments - typed-scheme/private/type-name-env - typed-scheme/private/type-rep - typed-scheme/private/type-utils - typed-scheme/private/typechecker - typed-scheme/private/unify - typed-scheme/private/union - typed-scheme/private/unit-utils - typed-scheme/private/utils - typed-scheme/typed-scheme)) - -(define big-libs-tests - (test-libs "Collections" modules-from-typed-scheme)) diff --git a/collects/tests/macro-debugger/tests/hiding.rkt b/collects/tests/macro-debugger/tests/hiding.rkt @@ -0,0 +1,207 @@ +#lang scheme/base +(require racunit) +(require macro-debugger/model/debug + "../test-setup.ss") +(provide specialized-hiding-tests) + +;; == Macro hiding + +(define-syntax test-hiding/policy + (syntax-rules () + [(th form hidden-e2 policy) + (test-case (format "~s" 'form) + (let-values ([(steps binders uses stx exn) + (parameterize ((macro-policy policy)) + (reductions+ (trace/k 'form)))]) + (check-pred syntax? stx) + (check-equal? (syntax->datum stx) 'hidden-e2)))])) + +(define-syntax test-trivial-hiding + (syntax-rules () + [(tth form hidden-e2) + (test-hiding/policy form hidden-e2 (lambda (m) #t))])) +(define-syntax test-trivial-hiding/id + (syntax-rules () + [(tthi form) + (test-trivial-hiding form form)])) + +(define-syntax-rule (test-T-hiding form hidden-e2) + (test-hiding/policy form hidden-e2 T-policy)) +(define-syntax-rule (test-T-hiding/id form) + (test-T-hiding form form)) + +(define-syntax-rule (test-Tm-hiding form hidden-e2) + (test-hiding/policy form hidden-e2 Tm-policy)) +(define-syntax-rule (test-Tm-hiding/id form) + (test-Tm-hiding form form)) + +(define specialized-hiding-tests + (test-suite "Specialized macro hiding tests" + + (test-suite "Result tests for trivial hiding" + (test-suite "Atomic expressions" + (test-trivial-hiding/id *) + (test-trivial-hiding 1 '1) + (test-trivial-hiding (#%datum . 1) '1) + (test-trivial-hiding unbound-var (#%top . unbound-var))) + (test-suite "Basic expressions" + (test-trivial-hiding/id (if * * *)) + (test-trivial-hiding/id (with-continuation-mark * * *)) + (test-trivial-hiding/id (define-values (x) *)) + (test-trivial-hiding/id (define-syntaxes (x) *))) + (test-suite "Binding expressions" + (test-trivial-hiding/id (lambda (x) *)) + (test-trivial-hiding/id (case-lambda [(x) *] [(x y) *])) + (test-trivial-hiding/id (let-values ([(x) *]) *)) + (test-trivial-hiding/id (letrec-values ([(x) *]) *))) + (test-suite "Blocks" + (test-trivial-hiding/id (lambda (x y) x y)) + (test-trivial-hiding (lambda (x y z) (begin x y) z) + (lambda (x y z) x y z)) + (test-trivial-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! + (test-trivial-hiding (lambda (x) (define-values (y) x) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-trivial-hiding (lambda (x) (begin (define-values (y) x)) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-trivial-hiding (lambda (x) (begin (define-values (y) x) y) x) + (lambda (x) (letrec-values ([(y) x]) y x))) + (test-trivial-hiding (lambda (x) (id (define-values (y) x)) x) + (lambda (x) (letrec-values ([(y) x]) x))) + (test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x))) + (lambda (x) (letrec-values ([(y) x]) x))) + (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-trivial-hiding (lambda (x y) x (id y)) + (lambda (x y) x y)) + (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) + (lambda (x) (letrec-values ([(y) x]) y)))) + #| + ;; Old hiding mechanism never did letrec transformation (unless forced) + (test-suite "Block normalization" + (test-trivial-hiding/id (lambda (x y) x y)) + (test-trivial-hiding/id (lambda (x y z) (begin x y) z)) + (test-trivial-hiding/id (lambda (x y z) x (begin y z))) + (test-trivial-hiding/id (lambda (x) (define-values (y) x) y)) + (test-trivial-hiding/id (lambda (x) (begin (define-values (y) x)) y)) + (test-trivial-hiding/id (lambda (x) (begin (define-values (y) x) y) x)) + (test-trivial-hiding (lambda (x) (id x)) + (lambda (x) x)) + (test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x))) + (lambda (x) (begin (define-values (y) x) x))) + (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) + (lambda (x) (define-values (y) x) y))) + |# + ) + + (test-suite "Result tests for T hiding" + (test-suite "Atomic expressions" + (test-T-hiding/id *) + (test-T-hiding/id 1) + (test-T-hiding/id unbound-var)) + (test-suite "Basic expressions" + (test-T-hiding/id (if 1 2 3)) + (test-T-hiding/id (with-continuation-mark 1 2 3)) + (test-T-hiding/id (define-values (x) 1)) + (test-T-hiding/id (define-syntaxes (x) 1))) + (test-suite "Opaque macros" + (test-T-hiding/id (id '1)) + (test-T-hiding/id (id 1)) + (test-T-hiding/id (id (id '1))) + ;; app is hidden: + (test-T-hiding/id (+ '1 '2))) + (test-suite "Transparent macros" + (test-T-hiding (Tlist x) + (list x)) + (test-T-hiding (Tid x) x) + (test-T-hiding (Tlist (id x)) + (list (id x))) + (test-T-hiding (Tid (id x)) + (id x)) + (test-T-hiding (id (Tlist x)) + (id (list x))) + (test-T-hiding (id (Tid x)) + (id x))) + (test-suite "Blocks" + (test-T-hiding/id (lambda (x y) x y)) + (test-T-hiding (lambda (x y z) (begin x y) z) + (lambda (x y z) x y z)) + (test-T-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! + (test-T-hiding (lambda (x) (define-values (y) x) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-T-hiding (lambda (x) (begin (define-values (y) x)) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-T-hiding (lambda (x) (begin (define-values (y) x) y) x) + (lambda (x) (letrec-values ([(y) x]) y x))) + (test-T-hiding (lambda (x) (id x)) + (lambda (x) (id x))) + (test-T-hiding (lambda (x) (Tid x)) + (lambda (x) x)) + (test-T-hiding/id (lambda (x) (id (define-values (y) x)) x)) + (test-T-hiding (lambda (x) (id (define-values (y) x)) (Tid x)) + (lambda (x) (id (define-values (y) x)) x)) + (test-T-hiding/id (lambda (x) (id (begin (define-values (y) x) x)))) + (test-T-hiding (lambda (x) (begin (id (define-values (y) x)) y)) + (lambda (x) (id (define-values (y) x)) y)) + (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y)) + (lambda (x) (id (begin (define-values (y) x))) y)) + (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y)) + (lambda (x) (id (begin (define-values (y) x))) x y)) + (test-T-hiding (lambda (x) (define-values (y) (id x)) y) + (lambda (x) (letrec-values ([(y) (id x)]) y))) + (test-T-hiding (lambda (x y) x (id y)) + (lambda (x y) x (id y))) + (test-T-hiding (lambda (x y) x (Tid y)) + (lambda (x y) x y)) + (test-T-hiding (lambda (x) (id (define-values (y) x)) x (Tid y)) + (lambda (x) (id (define-values (y) x)) x y)) + (test-T-hiding/id (lambda (x) (id (define-values (y) (id x))) y)) + (test-T-hiding (lambda (x) (id (define-values (y) (Tid x))) y) + (lambda (x) (id (define-values (y) x)) y))) + (test-suite "Binding expressions" + (test-T-hiding/id (lambda (x) x)) + (test-T-hiding/id (lambda (x) (id x)))) + (test-suite "Module declarations" + (test-T-hiding (module m mzscheme + (require 'helper) + (define x 1)) + (module m mzscheme + (require 'helper) + (define x 1))) + (test-Tm-hiding (module m mzscheme + (require 'helper) + (define x 1)) + (module m mzscheme + (#%module-begin + (require 'helper) + (define x 1)))) + + (test-T-hiding (module m mzscheme + (require 'helper) + (define x (Tlist 1))) + (module m mzscheme + (require 'helper) + (define x (list 1)))) + (test-Tm-hiding (module m mzscheme + (require 'helper) + (define x (Tlist 1))) + (module m mzscheme + (#%module-begin + (require 'helper) + (define x (list 1))))) + + (test-T-hiding (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (Tlist 1)))) + (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (list 1))))) + (test-Tm-hiding (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (Tlist 1)))) + (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (list 1))))))))) diff --git a/collects/tests/macro-debugger/tests/hiding.ss b/collects/tests/macro-debugger/tests/hiding.ss @@ -1,207 +0,0 @@ -#lang scheme/base -(require schemeunit) -(require macro-debugger/model/debug - "../test-setup.ss") -(provide specialized-hiding-tests) - -;; == Macro hiding - -(define-syntax test-hiding/policy - (syntax-rules () - [(th form hidden-e2 policy) - (test-case (format "~s" 'form) - (let-values ([(steps binders uses stx exn) - (parameterize ((macro-policy policy)) - (reductions+ (trace/k 'form)))]) - (check-pred syntax? stx) - (check-equal? (syntax->datum stx) 'hidden-e2)))])) - -(define-syntax test-trivial-hiding - (syntax-rules () - [(tth form hidden-e2) - (test-hiding/policy form hidden-e2 (lambda (m) #t))])) -(define-syntax test-trivial-hiding/id - (syntax-rules () - [(tthi form) - (test-trivial-hiding form form)])) - -(define-syntax-rule (test-T-hiding form hidden-e2) - (test-hiding/policy form hidden-e2 T-policy)) -(define-syntax-rule (test-T-hiding/id form) - (test-T-hiding form form)) - -(define-syntax-rule (test-Tm-hiding form hidden-e2) - (test-hiding/policy form hidden-e2 Tm-policy)) -(define-syntax-rule (test-Tm-hiding/id form) - (test-Tm-hiding form form)) - -(define specialized-hiding-tests - (test-suite "Specialized macro hiding tests" - - (test-suite "Result tests for trivial hiding" - (test-suite "Atomic expressions" - (test-trivial-hiding/id *) - (test-trivial-hiding 1 '1) - (test-trivial-hiding (#%datum . 1) '1) - (test-trivial-hiding unbound-var (#%top . unbound-var))) - (test-suite "Basic expressions" - (test-trivial-hiding/id (if * * *)) - (test-trivial-hiding/id (with-continuation-mark * * *)) - (test-trivial-hiding/id (define-values (x) *)) - (test-trivial-hiding/id (define-syntaxes (x) *))) - (test-suite "Binding expressions" - (test-trivial-hiding/id (lambda (x) *)) - (test-trivial-hiding/id (case-lambda [(x) *] [(x y) *])) - (test-trivial-hiding/id (let-values ([(x) *]) *)) - (test-trivial-hiding/id (letrec-values ([(x) *]) *))) - (test-suite "Blocks" - (test-trivial-hiding/id (lambda (x y) x y)) - (test-trivial-hiding (lambda (x y z) (begin x y) z) - (lambda (x y z) x y z)) - (test-trivial-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! - (test-trivial-hiding (lambda (x) (define-values (y) x) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-trivial-hiding (lambda (x) (begin (define-values (y) x)) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-trivial-hiding (lambda (x) (begin (define-values (y) x) y) x) - (lambda (x) (letrec-values ([(y) x]) y x))) - (test-trivial-hiding (lambda (x) (id (define-values (y) x)) x) - (lambda (x) (letrec-values ([(y) x]) x))) - (test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x))) - (lambda (x) (letrec-values ([(y) x]) x))) - (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-trivial-hiding (lambda (x y) x (id y)) - (lambda (x y) x y)) - (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (letrec-values ([(y) x]) y)))) - #| - ;; Old hiding mechanism never did letrec transformation (unless forced) - (test-suite "Block normalization" - (test-trivial-hiding/id (lambda (x y) x y)) - (test-trivial-hiding/id (lambda (x y z) (begin x y) z)) - (test-trivial-hiding/id (lambda (x y z) x (begin y z))) - (test-trivial-hiding/id (lambda (x) (define-values (y) x) y)) - (test-trivial-hiding/id (lambda (x) (begin (define-values (y) x)) y)) - (test-trivial-hiding/id (lambda (x) (begin (define-values (y) x) y) x)) - (test-trivial-hiding (lambda (x) (id x)) - (lambda (x) x)) - (test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x))) - (lambda (x) (begin (define-values (y) x) x))) - (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (define-values (y) x) y))) - |# - ) - - (test-suite "Result tests for T hiding" - (test-suite "Atomic expressions" - (test-T-hiding/id *) - (test-T-hiding/id 1) - (test-T-hiding/id unbound-var)) - (test-suite "Basic expressions" - (test-T-hiding/id (if 1 2 3)) - (test-T-hiding/id (with-continuation-mark 1 2 3)) - (test-T-hiding/id (define-values (x) 1)) - (test-T-hiding/id (define-syntaxes (x) 1))) - (test-suite "Opaque macros" - (test-T-hiding/id (id '1)) - (test-T-hiding/id (id 1)) - (test-T-hiding/id (id (id '1))) - ;; app is hidden: - (test-T-hiding/id (+ '1 '2))) - (test-suite "Transparent macros" - (test-T-hiding (Tlist x) - (list x)) - (test-T-hiding (Tid x) x) - (test-T-hiding (Tlist (id x)) - (list (id x))) - (test-T-hiding (Tid (id x)) - (id x)) - (test-T-hiding (id (Tlist x)) - (id (list x))) - (test-T-hiding (id (Tid x)) - (id x))) - (test-suite "Blocks" - (test-T-hiding/id (lambda (x y) x y)) - (test-T-hiding (lambda (x y z) (begin x y) z) - (lambda (x y z) x y z)) - (test-T-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! - (test-T-hiding (lambda (x) (define-values (y) x) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-T-hiding (lambda (x) (begin (define-values (y) x)) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-T-hiding (lambda (x) (begin (define-values (y) x) y) x) - (lambda (x) (letrec-values ([(y) x]) y x))) - (test-T-hiding (lambda (x) (id x)) - (lambda (x) (id x))) - (test-T-hiding (lambda (x) (Tid x)) - (lambda (x) x)) - (test-T-hiding/id (lambda (x) (id (define-values (y) x)) x)) - (test-T-hiding (lambda (x) (id (define-values (y) x)) (Tid x)) - (lambda (x) (id (define-values (y) x)) x)) - (test-T-hiding/id (lambda (x) (id (begin (define-values (y) x) x)))) - (test-T-hiding (lambda (x) (begin (id (define-values (y) x)) y)) - (lambda (x) (id (define-values (y) x)) y)) - (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y)) - (lambda (x) (id (begin (define-values (y) x))) y)) - (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y)) - (lambda (x) (id (begin (define-values (y) x))) x y)) - (test-T-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (letrec-values ([(y) (id x)]) y))) - (test-T-hiding (lambda (x y) x (id y)) - (lambda (x y) x (id y))) - (test-T-hiding (lambda (x y) x (Tid y)) - (lambda (x y) x y)) - (test-T-hiding (lambda (x) (id (define-values (y) x)) x (Tid y)) - (lambda (x) (id (define-values (y) x)) x y)) - (test-T-hiding/id (lambda (x) (id (define-values (y) (id x))) y)) - (test-T-hiding (lambda (x) (id (define-values (y) (Tid x))) y) - (lambda (x) (id (define-values (y) x)) y))) - (test-suite "Binding expressions" - (test-T-hiding/id (lambda (x) x)) - (test-T-hiding/id (lambda (x) (id x)))) - (test-suite "Module declarations" - (test-T-hiding (module m mzscheme - (require 'helper) - (define x 1)) - (module m mzscheme - (require 'helper) - (define x 1))) - (test-Tm-hiding (module m mzscheme - (require 'helper) - (define x 1)) - (module m mzscheme - (#%module-begin - (require 'helper) - (define x 1)))) - - (test-T-hiding (module m mzscheme - (require 'helper) - (define x (Tlist 1))) - (module m mzscheme - (require 'helper) - (define x (list 1)))) - (test-Tm-hiding (module m mzscheme - (require 'helper) - (define x (Tlist 1))) - (module m mzscheme - (#%module-begin - (require 'helper) - (define x (list 1))))) - - (test-T-hiding (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (Tlist 1)))) - (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (list 1))))) - (test-Tm-hiding (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (Tlist 1)))) - (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (list 1))))))))) diff --git a/collects/tests/macro-debugger/tests/policy.rkt b/collects/tests/macro-debugger/tests/policy.rkt @@ -0,0 +1,65 @@ +#lang scheme/base +(require racunit) +(require macro-debugger/model/debug + "../test-setup.ss") +(provide policy-tests) + +(define ns (make-base-namespace)) +(eval '(require (prefix-in k: '#%kernel)) ns) +(eval '(require (prefix-in base: scheme/base)) ns) +(eval '(require (prefix-in scheme: scheme)) ns) + +(define (make-test-id sym) + (parameterize ((current-namespace ns)) + (namespace-symbol->identifier sym))) + +(define-syntax-rule (test-policy policy name show?) + (test-case (format "~s" 'name) + (check-eq? (policy (make-test-id 'name)) + show?))) +(define-syntax-rule (test-standard name show?) + (test-policy standard-policy name show?)) +(define-syntax-rule (test-base name show?) + (test-policy base-policy name show?)) + +(define policy-tests + (test-suite "Policy tests" + (test-suite "Base policy" + ;; Kernel forms + (test-base k:define-values #f) + (test-base k:lambda #f) + (test-base k:if #f) + + ;; Scheme/base forms + (test-base base:define #f) + (test-base base:lambda #f) + (test-base base:#%app #f) + (test-base base:if #f) + + ;; Other Scheme/* forms + (test-base scheme:match #f) + (test-base scheme:unit #t) + (test-base scheme:class #f) + + ;; Unbound names + (test-base no-such-name #t) + ) + (test-suite "Standard policy" + ;; Kernel forms + (test-standard k:define-values #f) + (test-standard k:lambda #f) + (test-standard k:if #f) + + ;; Scheme/base forms + (test-standard base:define #f) + (test-standard base:lambda #f) + (test-standard base:#%app #f) + (test-standard base:if #f) + + ;; Other Scheme/* forms + (test-standard scheme:match #f) + (test-standard scheme:unit #f) + (test-standard scheme:class #f) + + ;; Unbound names + (test-standard no-such-name #t)))) diff --git a/collects/tests/macro-debugger/tests/policy.ss b/collects/tests/macro-debugger/tests/policy.ss @@ -1,65 +0,0 @@ -#lang scheme/base -(require schemeunit) -(require macro-debugger/model/debug - "../test-setup.ss") -(provide policy-tests) - -(define ns (make-base-namespace)) -(eval '(require (prefix-in k: '#%kernel)) ns) -(eval '(require (prefix-in base: scheme/base)) ns) -(eval '(require (prefix-in scheme: scheme)) ns) - -(define (make-test-id sym) - (parameterize ((current-namespace ns)) - (namespace-symbol->identifier sym))) - -(define-syntax-rule (test-policy policy name show?) - (test-case (format "~s" 'name) - (check-eq? (policy (make-test-id 'name)) - show?))) -(define-syntax-rule (test-standard name show?) - (test-policy standard-policy name show?)) -(define-syntax-rule (test-base name show?) - (test-policy base-policy name show?)) - -(define policy-tests - (test-suite "Policy tests" - (test-suite "Base policy" - ;; Kernel forms - (test-base k:define-values #f) - (test-base k:lambda #f) - (test-base k:if #f) - - ;; Scheme/base forms - (test-base base:define #f) - (test-base base:lambda #f) - (test-base base:#%app #f) - (test-base base:if #f) - - ;; Other Scheme/* forms - (test-base scheme:match #f) - (test-base scheme:unit #t) - (test-base scheme:class #f) - - ;; Unbound names - (test-base no-such-name #t) - ) - (test-suite "Standard policy" - ;; Kernel forms - (test-standard k:define-values #f) - (test-standard k:lambda #f) - (test-standard k:if #f) - - ;; Scheme/base forms - (test-standard base:define #f) - (test-standard base:lambda #f) - (test-standard base:#%app #f) - (test-standard base:if #f) - - ;; Other Scheme/* forms - (test-standard scheme:match #f) - (test-standard scheme:unit #f) - (test-standard scheme:class #f) - - ;; Unbound names - (test-standard no-such-name #t)))) diff --git a/collects/tests/macro-debugger/tests/regression.rkt b/collects/tests/macro-debugger/tests/regression.rkt @@ -0,0 +1,206 @@ +#lang scheme/base +(require racunit) +(require macro-debugger/model/debug + macro-debugger/model/steps + "../test-setup.ss") +(provide regression-tests) + +(define regression-tests + (test-suite "Regression tests" + ;; Fixed 9/2006: mismatched binding+bound variables + (test-case "hiding on binding forms" + (let ([stx (stx/hide-all (trace #'(let ([x 1]) x)))]) + (with-syntax ([(?let ([?x-def _]) ?x-use) stx]) + (check-pred identifier? #'?x-def) + (check-pred identifier? #'?x-use) + (check bound-identifier=? #'?x-def #'?x-use)))) + ;; Fixed 10/2/2006: bad handling of renames + (test-case "renames in lsv, etc" + (check-pred syntax? (stx/hide-none (trace #'(let () 1)))) + (check-pred syntax? (stx/hide-none (trace #'(letrec () 1)))) + (check-pred syntax? (stx/hide-none (trace #'(let-syntax () 1))))) + ;; Fixed 10/2/2006: error above manifests in classes, too + (test-case "renames in lsv, via class" + (check-pred syntax? (stx/hide-none (trace #'(class object% (super-new)))))) + ;; Fixed 10/2/2006: PR 8305: Error in module (pass2) + (test-case "interrupted expr in module body" + (check-equal? (stx/hide-standard + (trace '(module m mzscheme (define x (lambda))))) + #f) + (check-equal? (stx/hide-standard + (trace '(module m mzscheme (void) (define x (lambda))))) + #f)) + ;; Error in module (pass1) + (test-case "interrupted module-body element" + (check-equal? (stx/hide-standard (trace '(module m mzscheme (define x)))) + #f) + (check-equal? (stx/hide-standard (trace '(module m mzscheme (void) (define x)))) + #f)) + ;; Fixed 11/13/2006: error in lsv rhs + (test-case "error in lsv rhs" + (check-pred interrupted-node? + (trace #'(letrec-syntaxes+values ([(x) (error 'gotcha)]) () + 'never-reached)))) + ;; Fixed 11/13/2006: lifting in module + (test-case "lift in module" + (check-pred syntax? + (stx/hide-none + (trace '(module m mzscheme + (require mzlib/etc) + (define x (begin-lifted 1))))))) + + ;; Fixed 2/9/2007: defstx in brules misparsed & mishandled + (test-case "reductions & internal define-syntax" + (reductions + (trace '(let ([x 1]) + (define-syntax m + (syntax-rules () + [(_ x) (begin (lambda (x) x) (lambda (x) x) x)])) + (m x))))) + + ;; Fixed 2/9/2007: Handled b:defstx in hiding code + (test-case "reductions & internal define-syntax" + (check-pred syntax? + (stx/hide-none + (trace/t '(lambda () + (define-syntaxes (m) (lambda _ (quote-syntax *))) + (m)))))) + + ;; Fixed 2/9/2007: missing stx->list before length + (test-case "hiding error & stx pairs" + (check-pred syntax? + (stx/hide-none + (trace '(let-syntax ([m (syntax-rules () [(_ x) (begin x)])]) + (m *)))))) + (test-case "hiding in block, splicing" + (stx/hide-none + (trace '(let-syntax ([m (syntax-rules () [(_ x) (begin x)])]) + * + (m *))))) + (test-case "hiding in block, variable" + (stx/hide-none + (trace '(let-syntax ([m (syntax-rules () [(_ x) x])]) + (list (m *)) ;; FIXME + *)))) + (test-case "hiding in block, expression" + (check-pred syntax? + (stx/hide-none + (trace '(let-syntax ([m (syntax-rules () [(_ x) (list x)])]) + (m *)))))) + + ;; Reported by robby (2/8/2007), traced to bug in expander + (test-case "hiding & lambda in module" + (check-pred syntax? + (stx/hide-none + (trace '(module m '#%kernel + (#%module-begin (lambda () 'a))))))) + + ;; Discovered 5/7/2007 + (test-case "hiding and error within lambda" + (let ([rs (parameterize ((macro-policy hide-all-policy)) + (reductions (trace '(with-handlers () (lambda)))))]) + (check-pred list? rs) + (check-true (andmap misstep? rs)) + (check-true (= 1 (length rs))))) + + ;; Discovered 5/7/2007 + (test-case "hiding and error within lambda 2" + (let ([rs (parameterize ((macro-policy hide-all-policy)) + (reductions (trace '(with-handlers ([void void]) (lambda)))))]) + (check-pred list? rs) + (check-true (andmap misstep? rs)) + (check-true (= 1 (length rs))))) + + ;; Distilled from Robby bug report (5/12/2007) + ;; Fixed 5/17/2007 + (test-case "hiding: keeping lifts in sync" + (let ([freshname (gensym)]) + (eval `(module ,freshname mzscheme + (require (lib "contract.ss")) + (provide/contract [f (integer? . -> . integer?)] + [c integer?]) + (define (f x) (add1 x)) + (define c 1))) + (let ([rs (parameterize ((macro-policy standard-policy)) + (reductions + (trace `(module m mzscheme + (require ',freshname) + (define (g y) c) + (define h c) + (add1 (g 2))))))]) + (check-pred list? rs) + (check-true (andmap step? rs))))) + + ;; Bug from samth (6/5/2007) + ;; problem seems to come from define-syntax -> letrec-syntaxes+values + ;; transformation, undoes expansion of srhss (so rename fails) + (test-case "more rename/frontier troubles" + (let ([rs (reductions + (trace '(module m (lib "htdp-advanced.ss" "lang") + (local [(define x 1)] x))))]) + (check-pred list? rs))) + + ;; Distilled from Sam/typed-scheme (8/24/2007) + (test-case "transformer calls 'expand'" + (check-pred deriv? + (trace '(let-syntax ([m (lambda (stx) + (syntax-case stx () + [(m e) + (expand #'e)]))]) + (m 4))))) + (test-case "define-syntaxes rhs calls 'expand'" + (check-pred deriv? + (trace '(define-syntax m (expand '(or 1 2)))))) + (test-case "lsv rhs calls 'expand'" + (check-pred deriv? + (trace '(let-syntax ([m (expand '(or 1 2))]) 'nothing)))) + + ;; Added 2/18/2008 + (test-case "interrupted module-begin" + (let* ([freshname (gensym)] + [rs (parameterize ((macro-policy standard-policy)) + (reductions + (trace `(module m mzscheme + (require ,freshname) + (define (g y) c) + (define h c) + (add1 (g 2))))))]) + (check-pred list? rs) + (check-true (ormap misstep? rs)))) + + ;; Added 1/3/2008 + ;; Based on PR 10000 + (test-case "eval within module expansion" + (let ([freshname (gensym)]) + (eval `(module ,freshname scheme + (provide meval) + (define-syntax (meval stx) + (syntax-case stx () + [(meval e) + (parameterize ((current-namespace (make-base-namespace))) + (eval `(define one '1)) + (let ([v (eval `(+ 1 ,#'e))]) + #`(quote #,v)))])))) + (eval `(require ',freshname)) + (check-pred deriv? + (trace `(meval (+ 1 2)))) + (check-pred deriv? + (trace `(module m mzscheme + (require ',freshname) + (meval (+ 1 2))))))) + + (test-case "macro def within begin" + (let ([rs (reductions + (trace '(begin + (define-syntax-rule (m x e) + (define x e)) + (m y 12))))]) + (check-pred list? rs) + (check-false (ormap misstep? rs)) + (check-true (for/or ([step rs]) + (equal? (syntax->datum (state-e (protostep-s1 step))) + '(m y 12)) + (equal? (syntax->datum (state-e (step-s2 step))) + '(define y 12))) + "looking for m => define"))) + )) diff --git a/collects/tests/macro-debugger/tests/regression.ss b/collects/tests/macro-debugger/tests/regression.ss @@ -1,206 +0,0 @@ -#lang scheme/base -(require schemeunit) -(require macro-debugger/model/debug - macro-debugger/model/steps - "../test-setup.ss") -(provide regression-tests) - -(define regression-tests - (test-suite "Regression tests" - ;; Fixed 9/2006: mismatched binding+bound variables - (test-case "hiding on binding forms" - (let ([stx (stx/hide-all (trace #'(let ([x 1]) x)))]) - (with-syntax ([(?let ([?x-def _]) ?x-use) stx]) - (check-pred identifier? #'?x-def) - (check-pred identifier? #'?x-use) - (check bound-identifier=? #'?x-def #'?x-use)))) - ;; Fixed 10/2/2006: bad handling of renames - (test-case "renames in lsv, etc" - (check-pred syntax? (stx/hide-none (trace #'(let () 1)))) - (check-pred syntax? (stx/hide-none (trace #'(letrec () 1)))) - (check-pred syntax? (stx/hide-none (trace #'(let-syntax () 1))))) - ;; Fixed 10/2/2006: error above manifests in classes, too - (test-case "renames in lsv, via class" - (check-pred syntax? (stx/hide-none (trace #'(class object% (super-new)))))) - ;; Fixed 10/2/2006: PR 8305: Error in module (pass2) - (test-case "interrupted expr in module body" - (check-equal? (stx/hide-standard - (trace '(module m mzscheme (define x (lambda))))) - #f) - (check-equal? (stx/hide-standard - (trace '(module m mzscheme (void) (define x (lambda))))) - #f)) - ;; Error in module (pass1) - (test-case "interrupted module-body element" - (check-equal? (stx/hide-standard (trace '(module m mzscheme (define x)))) - #f) - (check-equal? (stx/hide-standard (trace '(module m mzscheme (void) (define x)))) - #f)) - ;; Fixed 11/13/2006: error in lsv rhs - (test-case "error in lsv rhs" - (check-pred interrupted-node? - (trace #'(letrec-syntaxes+values ([(x) (error 'gotcha)]) () - 'never-reached)))) - ;; Fixed 11/13/2006: lifting in module - (test-case "lift in module" - (check-pred syntax? - (stx/hide-none - (trace '(module m mzscheme - (require mzlib/etc) - (define x (begin-lifted 1))))))) - - ;; Fixed 2/9/2007: defstx in brules misparsed & mishandled - (test-case "reductions & internal define-syntax" - (reductions - (trace '(let ([x 1]) - (define-syntax m - (syntax-rules () - [(_ x) (begin (lambda (x) x) (lambda (x) x) x)])) - (m x))))) - - ;; Fixed 2/9/2007: Handled b:defstx in hiding code - (test-case "reductions & internal define-syntax" - (check-pred syntax? - (stx/hide-none - (trace/t '(lambda () - (define-syntaxes (m) (lambda _ (quote-syntax *))) - (m)))))) - - ;; Fixed 2/9/2007: missing stx->list before length - (test-case "hiding error & stx pairs" - (check-pred syntax? - (stx/hide-none - (trace '(let-syntax ([m (syntax-rules () [(_ x) (begin x)])]) - (m *)))))) - (test-case "hiding in block, splicing" - (stx/hide-none - (trace '(let-syntax ([m (syntax-rules () [(_ x) (begin x)])]) - * - (m *))))) - (test-case "hiding in block, variable" - (stx/hide-none - (trace '(let-syntax ([m (syntax-rules () [(_ x) x])]) - (list (m *)) ;; FIXME - *)))) - (test-case "hiding in block, expression" - (check-pred syntax? - (stx/hide-none - (trace '(let-syntax ([m (syntax-rules () [(_ x) (list x)])]) - (m *)))))) - - ;; Reported by robby (2/8/2007), traced to bug in expander - (test-case "hiding & lambda in module" - (check-pred syntax? - (stx/hide-none - (trace '(module m '#%kernel - (#%module-begin (lambda () 'a))))))) - - ;; Discovered 5/7/2007 - (test-case "hiding and error within lambda" - (let ([rs (parameterize ((macro-policy hide-all-policy)) - (reductions (trace '(with-handlers () (lambda)))))]) - (check-pred list? rs) - (check-true (andmap misstep? rs)) - (check-true (= 1 (length rs))))) - - ;; Discovered 5/7/2007 - (test-case "hiding and error within lambda 2" - (let ([rs (parameterize ((macro-policy hide-all-policy)) - (reductions (trace '(with-handlers ([void void]) (lambda)))))]) - (check-pred list? rs) - (check-true (andmap misstep? rs)) - (check-true (= 1 (length rs))))) - - ;; Distilled from Robby bug report (5/12/2007) - ;; Fixed 5/17/2007 - (test-case "hiding: keeping lifts in sync" - (let ([freshname (gensym)]) - (eval `(module ,freshname mzscheme - (require (lib "contract.ss")) - (provide/contract [f (integer? . -> . integer?)] - [c integer?]) - (define (f x) (add1 x)) - (define c 1))) - (let ([rs (parameterize ((macro-policy standard-policy)) - (reductions - (trace `(module m mzscheme - (require ',freshname) - (define (g y) c) - (define h c) - (add1 (g 2))))))]) - (check-pred list? rs) - (check-true (andmap step? rs))))) - - ;; Bug from samth (6/5/2007) - ;; problem seems to come from define-syntax -> letrec-syntaxes+values - ;; transformation, undoes expansion of srhss (so rename fails) - (test-case "more rename/frontier troubles" - (let ([rs (reductions - (trace '(module m (lib "htdp-advanced.ss" "lang") - (local [(define x 1)] x))))]) - (check-pred list? rs))) - - ;; Distilled from Sam/typed-scheme (8/24/2007) - (test-case "transformer calls 'expand'" - (check-pred deriv? - (trace '(let-syntax ([m (lambda (stx) - (syntax-case stx () - [(m e) - (expand #'e)]))]) - (m 4))))) - (test-case "define-syntaxes rhs calls 'expand'" - (check-pred deriv? - (trace '(define-syntax m (expand '(or 1 2)))))) - (test-case "lsv rhs calls 'expand'" - (check-pred deriv? - (trace '(let-syntax ([m (expand '(or 1 2))]) 'nothing)))) - - ;; Added 2/18/2008 - (test-case "interrupted module-begin" - (let* ([freshname (gensym)] - [rs (parameterize ((macro-policy standard-policy)) - (reductions - (trace `(module m mzscheme - (require ,freshname) - (define (g y) c) - (define h c) - (add1 (g 2))))))]) - (check-pred list? rs) - (check-true (ormap misstep? rs)))) - - ;; Added 1/3/2008 - ;; Based on PR 10000 - (test-case "eval within module expansion" - (let ([freshname (gensym)]) - (eval `(module ,freshname scheme - (provide meval) - (define-syntax (meval stx) - (syntax-case stx () - [(meval e) - (parameterize ((current-namespace (make-base-namespace))) - (eval `(define one '1)) - (let ([v (eval `(+ 1 ,#'e))]) - #`(quote #,v)))])))) - (eval `(require ',freshname)) - (check-pred deriv? - (trace `(meval (+ 1 2)))) - (check-pred deriv? - (trace `(module m mzscheme - (require ',freshname) - (meval (+ 1 2))))))) - - (test-case "macro def within begin" - (let ([rs (reductions - (trace '(begin - (define-syntax-rule (m x e) - (define x e)) - (m y 12))))]) - (check-pred list? rs) - (check-false (ormap misstep? rs)) - (check-true (for/or ([step rs]) - (equal? (syntax->datum (state-e (protostep-s1 step))) - '(m y 12)) - (equal? (syntax->datum (state-e (step-s2 step))) - '(define y 12))) - "looking for m => define"))) - )) diff --git a/collects/tests/macro-debugger/tests/syntax-basic.ss b/collects/tests/macro-debugger/tests/syntax-basic.rkt diff --git a/collects/tests/macro-debugger/tests/syntax-errors.ss b/collects/tests/macro-debugger/tests/syntax-errors.rkt diff --git a/collects/tests/macro-debugger/tests/syntax-macros.ss b/collects/tests/macro-debugger/tests/syntax-macros.rkt diff --git a/collects/tests/macro-debugger/tests/syntax-modules.ss b/collects/tests/macro-debugger/tests/syntax-modules.rkt diff --git a/collects/unstable/find.rkt b/collects/unstable/find.rkt @@ -0,0 +1,73 @@ +#lang racket/base +(require racket/contract + unstable/struct) + +(provide/contract + [find + (->* ((-> any/c any/c) + any/c) + (#:stop-on-found? any/c + #:stop (or/c #f (-> any/c any/c)) + #:get-children (or/c #f (-> any/c (or/c #f list?)))) + list?)] + [find-first + (->* ((-> any/c any/c) + any/c) + (#:stop (or/c #f (-> any/c any/c)) + #:get-children (or/c #f (-> any/c (or/c #f list?))) + #:default any/c) + any/c)]) + +(define (find pred x + #:stop-on-found? [stop-on-found? #f] + #:stop [stop #f] + #:get-children [get-children #f]) + (define (loop x acc) + (cond [(pred x) + (let ([acc (cons x acc)]) + (if stop-on-found? + acc + (loop/nf x acc)))] + [else + (loop/nf x acc)])) + ;; loop/nt: x is "not found"; look in its children + (define (loop/nf x acc) + (cond [(and stop (stop x)) + acc] + [(and get-children (get-children x)) + => (lambda (children) (loop* children acc))] + [(pair? x) + (let ([acc (loop (car x) acc)]) + (loop (cdr x) acc))] + [(vector? x) + (for/fold ([acc acc]) ([elem (in-vector x)]) + (loop elem acc))] + [(box? x) + (loop (unbox x) acc)] + [(struct->list x #:on-opaque 'skip) + => (lambda (elems) + (loop* elems acc))] + ;; unreachable, since + ;; (struct->list X #:on-opaque 'skip) always returns a list + [else acc])) + (define (loop* xs acc) + (for/fold ([acc acc]) ([elem (in-list xs)]) + (loop elem acc))) + (reverse (loop x null))) +;; Eli: This looks borderline too generic to be useful, also in the fact that +;; the documentation tends to explain things in terms of the implementation +;; (eg, the description of #:stop). In any case, you should definitely +;; rename it -- `find' is too common in different ways (see srfi-1 or cltl). + +(define (find-first pred x + #:stop [stop #f] + #:get-children [get-children #f] + #:default [default #f]) + (let/ec return + (define (pred* x) + (and (pred x) (return x))) + (find pred* x #:stop stop #:get-children get-children) + (if (procedure? default) + (default) + default))) +;; Eli: Note that this is documented "Like `find-first'". diff --git a/collects/unstable/find.ss b/collects/unstable/find.ss @@ -1,73 +0,0 @@ -#lang scheme/base -(require scheme/contract - unstable/struct) - -(provide/contract - [find - (->* ((-> any/c any/c) - any/c) - (#:stop-on-found? any/c - #:stop (or/c #f (-> any/c any/c)) - #:get-children (or/c #f (-> any/c (or/c #f list?)))) - list?)] - [find-first - (->* ((-> any/c any/c) - any/c) - (#:stop (or/c #f (-> any/c any/c)) - #:get-children (or/c #f (-> any/c (or/c #f list?))) - #:default any/c) - any/c)]) - -(define (find pred x - #:stop-on-found? [stop-on-found? #f] - #:stop [stop #f] - #:get-children [get-children #f]) - (define (loop x acc) - (cond [(pred x) - (let ([acc (cons x acc)]) - (if stop-on-found? - acc - (loop/nf x acc)))] - [else - (loop/nf x acc)])) - ;; loop/nt: x is "not found"; look in its children - (define (loop/nf x acc) - (cond [(and stop (stop x)) - acc] - [(and get-children (get-children x)) - => (lambda (children) (loop* children acc))] - [(pair? x) - (let ([acc (loop (car x) acc)]) - (loop (cdr x) acc))] - [(vector? x) - (for/fold ([acc acc]) ([elem (in-vector x)]) - (loop elem acc))] - [(box? x) - (loop (unbox x) acc)] - [(struct->list x #:on-opaque 'skip) - => (lambda (elems) - (loop* elems acc))] - ;; unreachable, since - ;; (struct->list X #:on-opaque 'skip) always returns a list - [else acc])) - (define (loop* xs acc) - (for/fold ([acc acc]) ([elem (in-list xs)]) - (loop elem acc))) - (reverse (loop x null))) -;; Eli: This looks borderline too generic to be useful, also in the fact that -;; the documentation tends to explain things in terms of the implementation -;; (eg, the description of #:stop). In any case, you should definitely -;; rename it -- `find' is too common in different ways (see srfi-1 or cltl). - -(define (find-first pred x - #:stop [stop #f] - #:get-children [get-children #f] - #:default [default #f]) - (let/ec return - (define (pred* x) - (and (pred x) (return x))) - (find pred* x #:stop stop #:get-children get-children) - (if (procedure? default) - (default) - default))) -;; Eli: Note that this is documented "Like `find-first'". diff --git a/collects/unstable/scribblings/find.scrbl b/collects/unstable/scribblings/find.scrbl @@ -1,20 +1,20 @@ #lang scribble/manual @(require scribble/eval - "utils.ss" + "utils.rkt" (for-label unstable/find - scheme/contract - scheme/shared - scheme/base)) + racket/contract + racket/shared + racket/base)) @title[#:tag "find"]{Find} @(define the-eval (make-base-eval)) @(the-eval '(require unstable/find)) -@(the-eval '(require scheme/shared)) +@(the-eval '(require racket/shared)) @defmodule[unstable/find] -@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]] +@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] @defproc[(find [pred (-> any/c any/c)] [x any/c] @@ -23,23 +23,23 @@ [#:get-children get-children (or/c #f (-> any/c (or/c #f list?))) #f]) list?]{ -Returns a list of all values satisfying @scheme[pred] contained in -@scheme[x] (possibly including @scheme[x] itself). +Returns a list of all values satisfying @racket[pred] contained in +@racket[x] (possibly including @racket[x] itself). -If @scheme[stop-on-found?] is true, the children of values satisfying -@scheme[pred] are not examined. If @scheme[stop] is a procedure, then -the children of values for which @scheme[stop] returns true are not -examined (but the values themselves are; @scheme[stop] is applied -after @scheme[pred]). Only the current branch of the search is +If @racket[stop-on-found?] is true, the children of values satisfying +@racket[pred] are not examined. If @racket[stop] is a procedure, then +the children of values for which @racket[stop] returns true are not +examined (but the values themselves are; @racket[stop] is applied +after @racket[pred]). Only the current branch of the search is stopped, not the whole search. The search recurs through pairs, vectors, boxes, and the accessible -fields of structures. If @scheme[get-children] is a procedure, it can +fields of structures. If @racket[get-children] is a procedure, it can override the default notion of a value's children by returning a list (if it returns false, the default notion of children is used). -No cycle detection is done, so @scheme[find] on a cyclic graph may -diverge. To do cycle checking yourself, use @scheme[stop] and a +No cycle detection is done, so @racket[find] on a cyclic graph may +diverge. To do cycle checking yourself, use @racket[stop] and a mutable table. @examples[#:eval the-eval @@ -63,8 +63,8 @@ mutable table. [#:default default any/c (lambda () (error ....))]) any/c]{ -Like @scheme[find], but only returns the first match. If no -matches are found, @scheme[default] is applied as a thunk if it is a +Like @racket[find], but only returns the first match. If no +matches are found, @racket[default] is applied as a thunk if it is a procedure or returned otherwise. @examples[#:eval the-eval