From 9c931912419d0199c5cd7c9e6b5b3ad0571de7da Mon Sep 17 00:00:00 2001 From: John Clements Date: Mon, 13 Apr 2009 23:48:15 +0000 Subject: [PATCH] jump-to-beginning-of-selected svn: r14501 --- collects/stepper/private/marks.ss | 356 +++--- collects/stepper/private/model.ss | 486 ++++---- collects/stepper/private/mred-extensions.ss | 12 +- collects/stepper/private/reconstruct.ss | 8 +- collects/stepper/private/shared.ss | 284 +++-- collects/stepper/stepper+xml-tool.ss | 7 +- collects/stepper/stepper-tool.ss | 1095 +++++++------------ 7 files changed, 962 insertions(+), 1286 deletions(-) diff --git a/collects/stepper/private/marks.ss b/collects/stepper/private/marks.ss index a07778dbd9..0c1695a338 100644 --- a/collects/stepper/private/marks.ss +++ b/collects/stepper/private/marks.ss @@ -1,183 +1,183 @@ -(module marks scheme/base +#lang scheme/base - (require mzlib/list - mzlib/contract - "my-macros.ss" - "shared.ss" - #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")) +(require mzlib/list + mzlib/contract + "my-macros.ss" + "shared.ss" + #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")) - (define-struct full-mark-struct (source label bindings values)) +(define-struct full-mark-struct (source label bindings values)) - ; CONTRACTS - (define mark? (-> ; no args - full-mark-struct?)) - (define mark-list? (listof procedure?)) - - (provide/contract - ;[make-debug-info (any/c binding-set? varref-set? any/c boolean? . -> . syntax?)] ; (location tail-bound free label lifting? -> mark-stx) - [expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))] - [make-top-level-mark (syntax? . -> . syntax?)] - [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))] - [lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any/c)] - [lookup-binding (mark-list? identifier? . -> . any)]) - - (provide - make-debug-info - wcm-wrap - skipto-mark? - skipto-mark - strip-skiptos - mark-list? - mark-source - mark-bindings - mark-label - mark-binding-value - mark-binding-binding - display-mark - all-bindings - #;lookup-binding-list - debug-key - extract-mark-list - (struct-out normal-breakpoint-info) - (struct-out error-breakpoint-info) - (struct-out breakpoint-halt) - (struct-out expression-finished)) - - ; BREAKPOINT STRUCTURES - - (define-struct normal-breakpoint-info (mark-list kind)) - (define-struct error-breakpoint-info (message)) - (define-struct breakpoint-halt ()) - (define-struct expression-finished (returned-value-list)) - - (define-struct skipto-mark-struct ()) - (define skipto-mark? skipto-mark-struct?) - (define skipto-mark (make-skipto-mark-struct)) - (define (strip-skiptos mark-list) - (filter (lx (not (skipto-mark? _))) mark-list)) - - - ; debug-key: this key will be used as a key for the continuation marks. - (define-struct debug-key-struct ()) - (define debug-key (make-debug-key-struct)) - - (define (extract-mark-list mark-set) - (strip-skiptos (continuation-mark-set->list mark-set debug-key))) - - - ; the 'varargs' creator is used to avoid an extra cons cell in every mark: - (define (make-make-full-mark-varargs source label bindings) - (lambda values - (make-full-mark-struct source label bindings values))) - - ; see module top for type - (define (make-full-mark location label bindings) - (datum->syntax #'here `(#%plain-lambda () (#%plain-app ,(make-make-full-mark-varargs location label bindings) - ,@(map make-mark-binding-stx bindings))))) - - (define (mark-source mark) - (full-mark-struct-source (mark))) - - (define (make-mark-binding-stx id) - #`(#%plain-lambda () #,id)) - - (define (mark-bindings mark) - (map list - (full-mark-struct-bindings (mark)) - (full-mark-struct-values (mark)))) - - (define (mark-label mark) - (full-mark-struct-label (mark))) - - (define (mark-binding-value mark-binding) - ((cadr mark-binding))) - - (define (mark-binding-binding mark-binding) - (car mark-binding)) +; CONTRACTS +(define mark? (-> ; no args + full-mark-struct?)) +(define mark-list? (listof procedure?)) - (define (expose-mark mark) - (let ([source (mark-source mark)] - [label (mark-label mark)] - [bindings (mark-bindings mark)]) - (list source - label - (map (lambda (binding) - (list (mark-binding-binding binding) - (mark-binding-value binding))) - bindings)))) - - (define (display-mark mark) - (apply - string-append - (format "source: ~a\n" (syntax->datum (mark-source mark))) - (format "label: ~a\n" (mark-label mark)) - (format "bindings:\n") - (map (lambda (binding) - (format " ~a : ~a\n" (syntax-e (mark-binding-binding binding)) - (mark-binding-value binding))) - (mark-bindings mark)))) - - - ; possible optimization: rig the mark-maker to guarantee statically that a - ; variable can occur at most once in a mark. - - (define (binding-matches matcher mark) - (filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark))) - - (define (lookup-all-bindings matcher mark-list) - (apply append (map (lambda (m) (binding-matches matcher m)) mark-list))) - - (define (lookup-first-binding matcher mark-list fail-thunk) - (let ([all-bindings (lookup-all-bindings matcher mark-list)]) - (if (null? all-bindings) - (fail-thunk) - (car all-bindings)))) - - (define (lookup-binding mark-list id) - (mark-binding-value - (lookup-first-binding (lambda (id2) (free-identifier=? id id2)) - mark-list - (lambda () - (error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) - (syntax->datum id) - id)))))) - - (define (all-bindings mark) - (map mark-binding-binding (mark-bindings mark))) - - (define (wcm-wrap debug-info expr) - #`(with-continuation-mark #,debug-key #,debug-info #,expr)) +(provide/contract + ;[make-debug-info (any/c binding-set? varref-set? any/c boolean? . -> . syntax?)] ; (location tail-bound free label lifting? -> mark-stx) + [expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))] + [make-top-level-mark (syntax? . -> . syntax?)] + [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))] + [lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any/c)] + [lookup-binding (mark-list? identifier? . -> . any)]) - - ; DEBUG-INFO STRUCTURES - - ;;;;;;;;;; - ;; - ;; make-debug-info builds the thunk which will be the mark at runtime. It contains - ;; a source expression and a set of binding/value pairs. - ;; (syntax-object BINDING-SET VARREF-SET any boolean (union/c false/c integer?)) -> debug-info) - ;; - ;;;;;;;;;; - - (define (make-debug-info source tail-bound free-vars label lifting?) - (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)]) - (if lifting? - (let*-2vals ([let-bindings (filter (lambda (var) - (and - (case (stepper-syntax-property var 'stepper-binding-type) - ((let-bound macro-bound) #t) - ((lambda-bound stepper-temp non-lexical) #f) - (else (error 'make-debug-info - "varref ~a's binding-type info was not recognized: ~a" - (syntax-e var) - (stepper-syntax-property var 'stepper-binding-type)))) - (not (stepper-syntax-property var 'stepper-no-lifting-info)))) - kept-vars)] - [lifter-syms (map get-lifted-var let-bindings)]) - (make-full-mark source label (append kept-vars lifter-syms))) - ;; I'm not certain that non-lifting is currently tested: 2005-12, JBC - (make-full-mark source label kept-vars)))) - - - (define (make-top-level-mark source-expr) - (make-full-mark source-expr 'top-level null))) +(provide + make-debug-info + wcm-wrap + skipto-mark? + skipto-mark + strip-skiptos + mark-list? + mark-source + mark-bindings + mark-label + mark-binding-value + mark-binding-binding + display-mark + all-bindings + #;lookup-binding-list + debug-key + extract-mark-list + (struct-out normal-breakpoint-info) + (struct-out error-breakpoint-info) + (struct-out breakpoint-halt) + (struct-out expression-finished)) + +; BREAKPOINT STRUCTURES + +(define-struct normal-breakpoint-info (mark-list kind)) +(define-struct error-breakpoint-info (message)) +(define-struct breakpoint-halt ()) +(define-struct expression-finished (returned-value-list)) + +(define-struct skipto-mark-struct ()) +(define skipto-mark? skipto-mark-struct?) +(define skipto-mark (make-skipto-mark-struct)) +(define (strip-skiptos mark-list) + (filter (lx (not (skipto-mark? _))) mark-list)) + + +; debug-key: this key will be used as a key for the continuation marks. +(define-struct debug-key-struct ()) +(define debug-key (make-debug-key-struct)) + +(define (extract-mark-list mark-set) + (strip-skiptos (continuation-mark-set->list mark-set debug-key))) + + +; the 'varargs' creator is used to avoid an extra cons cell in every mark: +(define (make-make-full-mark-varargs source label bindings) + (lambda values + (make-full-mark-struct source label bindings values))) + +; see module top for type +(define (make-full-mark location label bindings) + (datum->syntax #'here `(#%plain-lambda () (#%plain-app ,(make-make-full-mark-varargs location label bindings) + ,@(map make-mark-binding-stx bindings))))) + +(define (mark-source mark) + (full-mark-struct-source (mark))) + +(define (make-mark-binding-stx id) + #`(#%plain-lambda () #,id)) + +(define (mark-bindings mark) + (map list + (full-mark-struct-bindings (mark)) + (full-mark-struct-values (mark)))) + +(define (mark-label mark) + (full-mark-struct-label (mark))) + +(define (mark-binding-value mark-binding) + ((cadr mark-binding))) + +(define (mark-binding-binding mark-binding) + (car mark-binding)) + +(define (expose-mark mark) + (let ([source (mark-source mark)] + [label (mark-label mark)] + [bindings (mark-bindings mark)]) + (list source + label + (map (lambda (binding) + (list (mark-binding-binding binding) + (mark-binding-value binding))) + bindings)))) + +(define (display-mark mark) + (apply + string-append + (format "source: ~a\n" (syntax->datum (mark-source mark))) + (format "label: ~a\n" (mark-label mark)) + (format "bindings:\n") + (map (lambda (binding) + (format " ~a : ~a\n" (syntax-e (mark-binding-binding binding)) + (mark-binding-value binding))) + (mark-bindings mark)))) + + +; possible optimization: rig the mark-maker to guarantee statically that a +; variable can occur at most once in a mark. + +(define (binding-matches matcher mark) + (filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark))) + +(define (lookup-all-bindings matcher mark-list) + (apply append (map (lambda (m) (binding-matches matcher m)) mark-list))) + +(define (lookup-first-binding matcher mark-list fail-thunk) + (let ([all-bindings (lookup-all-bindings matcher mark-list)]) + (if (null? all-bindings) + (fail-thunk) + (car all-bindings)))) + +(define (lookup-binding mark-list id) + (mark-binding-value + (lookup-first-binding (lambda (id2) (free-identifier=? id id2)) + mark-list + (lambda () + (error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) + (syntax->datum id) + id)))))) + +(define (all-bindings mark) + (map mark-binding-binding (mark-bindings mark))) + +(define (wcm-wrap debug-info expr) + #`(with-continuation-mark #,debug-key #,debug-info #,expr)) + + +; DEBUG-INFO STRUCTURES + +;;;;;;;;;; +;; +;; make-debug-info builds the thunk which will be the mark at runtime. It contains +;; a source expression and a set of binding/value pairs. +;; (syntax-object BINDING-SET VARREF-SET any boolean (union/c false/c integer?)) -> debug-info) +;; +;;;;;;;;;; + +(define (make-debug-info source tail-bound free-vars label lifting?) + (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)]) + (if lifting? + (let*-2vals ([let-bindings (filter (lambda (var) + (and + (case (stepper-syntax-property var 'stepper-binding-type) + ((let-bound macro-bound) #t) + ((lambda-bound stepper-temp non-lexical) #f) + (else (error 'make-debug-info + "varref ~a's binding-type info was not recognized: ~a" + (syntax-e var) + (stepper-syntax-property var 'stepper-binding-type)))) + (not (stepper-syntax-property var 'stepper-no-lifting-info)))) + kept-vars)] + [lifter-syms (map get-lifted-var let-bindings)]) + (make-full-mark source label (append kept-vars lifter-syms))) + ;; I'm not certain that non-lifting is currently tested: 2005-12, JBC + (make-full-mark source label kept-vars)))) + + +(define (make-top-level-mark source-expr) + (make-full-mark source-expr 'top-level null)) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index e281a90fe4..65df49dc15 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -35,165 +35,167 @@ ; double(x) : ERROR ; late-let(x) : ERROR +#lang scheme/base -(module model scheme/base - (require scheme/contract - scheme/match - scheme/class - scheme/list - (prefix-in a: "annotate.ss") - (prefix-in r: "reconstruct.ss") - "shared.ss" - "marks.ss" - "model-settings.ss" - "macro-unwind.ss" - "lifting.ss" - (prefix-in test-engine: test-engine/scheme-tests) - #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") - ;; for breakpoint display - ;; (commented out to allow nightly testing) - #;"display-break-stuff.ss") +(require scheme/contract + scheme/match + scheme/class + scheme/list + (prefix-in a: "annotate.ss") + (prefix-in r: "reconstruct.ss") + "shared.ss" + "marks.ss" + "model-settings.ss" + "macro-unwind.ss" + "lifting.ss" + (prefix-in test-engine: test-engine/scheme-tests) + #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") + ;; for breakpoint display + ;; (commented out to allow nightly testing) + #;"display-break-stuff.ss") - (define program-expander-contract - ((-> void?) ; init - ((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) - . -> . void?) ; iter - . -> . - void?)) +(define program-expander-contract + ((-> void?) ; init + ((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) + . -> . void?) ; iter + . -> . + void?)) - (provide/contract - [go (program-expander-contract ; program-expander - (step-result? . -> . void?) ; receive-result - (or/c render-settings? false/c) ; render-settings - boolean? ; track-inferred-names? - (or/c object? (symbols 'testing)) ;; FIXME: can do better: subclass of language% ; the language level - (procedure? . -> . void?) ; run-on-drscheme-side - boolean? ; disable-error-handling (to allow debugging) - . -> . - void?)]) +(provide/contract + [go (program-expander-contract ; program-expander + (step-result? . -> . void?) ; receive-result + (or/c render-settings? false/c) ; render-settings + boolean? ; track-inferred-names? + (or/c object? (symbols 'testing)) ;; FIXME: can do better: subclass of language% ; the language level + (procedure? . -> . void?) ; run-on-drscheme-side + boolean? ; disable-error-handling (to allow debugging) + . -> . + void?)]) - ; go starts a stepper instance - ; see provide stmt for contract - (define (go program-expander receive-result render-settings - show-lambdas-as-lambdas? language-level run-on-drscheme-side - disable-error-handling) - - ;; finished-exps: - ;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) - ;; because of mutation, these cannot be fixed renderings, but must be - ;; re-rendered at each step. - (define finished-exps null) - (define/contract add-to-finished - ((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any) - . -> . void?) - (lambda (exp-thunk lifting-indices getter) - (set! finished-exps - (append finished-exps - (list (list exp-thunk lifting-indices getter)))))) - - ;; the "held" variables are used to store the "before" step. - (define held-exp-list no-sexp) - (define held-step-was-app? #f) - (define held-finished-list null) - - ;; highlight-mutated-expressions : - ;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) - ;; -> (list/c (listof syntax?) (listof syntax?))) - ;; highlights changes occurring due to mutation. This function accepts the - ;; left-hand-side expressions and the right-hand-side expressions, and - ;; matches them against each other to see which ones have changed due to - ;; mutation, and highlights these. - ;; POSSIBLE RESEARCH POINT: if, say, (list 3 4) is mutated to (list 4 5), - ;; should the 4 & 5 be highlighted individually or should the list as a - ;; whole be highlighted. Is either one "wrong?" equivalences between - ;; reduction semantics? - ;; - ;; 2005-11-14: punting. just highlight the whole darn thing if there are - ;; any differences. In fact, just test for eq?-ness. - - #; - (define (highlight-mutated-expressions lefts rights) - (if (or (null? lefts) (null? rights)) +; go starts a stepper instance +; see provide stmt for contract +(define (go program-expander receive-result render-settings + show-lambdas-as-lambdas? language-level run-on-drscheme-side + disable-error-handling) + + ;; finished-exps: + ;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) + ;; because of mutation, these cannot be fixed renderings, but must be + ;; re-rendered at each step. + (define finished-exps null) + (define/contract add-to-finished + ((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any) + . -> . void?) + (lambda (exp-thunk lifting-indices getter) + (set! finished-exps + (append finished-exps + (list (list exp-thunk lifting-indices getter)))))) + + ;; the "held" variables are used to store the "before" step. + (define held-exp-list the-no-sexp) + + (define-struct held (exps was-app? source-pos)) + + (define held-finished-list null) + + ;; highlight-mutated-expressions : + ;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) + ;; -> (list/c (listof syntax?) (listof syntax?))) + ;; highlights changes occurring due to mutation. This function accepts the + ;; left-hand-side expressions and the right-hand-side expressions, and + ;; matches them against each other to see which ones have changed due to + ;; mutation, and highlights these. + ;; POSSIBLE RESEARCH POINT: if, say, (list 3 4) is mutated to (list 4 5), + ;; should the 4 & 5 be highlighted individually or should the list as a + ;; whole be highlighted. Is either one "wrong?" equivalences between + ;; reduction semantics? + ;; + ;; 2005-11-14: punting. just highlight the whole darn thing if there are + ;; any differences. In fact, just test for eq?-ness. + + #; + (define (highlight-mutated-expressions lefts rights) + (if (or (null? lefts) (null? rights)) (list lefts rights) (let ([left-car (car lefts)] [right-car (car rights)]) (if (eq? (syntax-property left-car 'user-source) (syntax-property right-car 'user-source)) - (let ([highlights-added - (highlight-mutated-expression left-car right-car)] - [rest (highlight-mutated-expressions - (cdr lefts) (cdr rights))]) - (cons (cons (car highlights-added) (car rest)) - (cons (cadr highlights-added) (cadr rest)))))))) - - ;; highlight-mutated-expression: syntax? syntax? -> syntax? - ;; given two expressions, highlight 'em both if they differ at all. - - ;; notes: wanted to use simple "eq?" test... but this will fail when a - ;; being-stepped definition (e.g. in a let) turns into a permanent one. - ;; We pay a terrible price for the lifting thing. And, for the fact that - ;; the highlighting follows from the reductions but can't obviously be - ;; deduced from them. - - #; - (define (highlight-mutated-expression left right) - (cond - ;; if either one is already highlighted, leave them alone. - [(or (stepper-syntax-property left 'stepper-highlight) - (stepper-syntax-property right 'stepper-highlight)) - (list left right)] - - ;; first pass: highlight if not eq?. Should be broken for local-bound - ;; things as they pass into permanence. - [(eq? left right) - (list left right)] - - [else (list (stepper-syntax-property left 'stepper-highlight) - (stepper-syntax-property right 'stepper-highlight))])) - - ;; mutated on receipt of a break, used in displaying breakpoint stuff. - (define steps-received 0) - - (define break - (lambda (mark-set break-kind [returned-value-list #f]) - - (set! steps-received (+ steps-received 1)) - ;; have to be careful else this won't be looked up right away: - ;; (commented out to allow nightly tests to proceed, 2007-09-04 - #;(when (getenv "PLTSTEPPERUNSAFE") + (let ([highlights-added + (highlight-mutated-expression left-car right-car)] + [rest (highlight-mutated-expressions + (cdr lefts) (cdr rights))]) + (cons (cons (car highlights-added) (car rest)) + (cons (cadr highlights-added) (cadr rest)))))))) + + ;; highlight-mutated-expression: syntax? syntax? -> syntax? + ;; given two expressions, highlight 'em both if they differ at all. + + ;; notes: wanted to use simple "eq?" test... but this will fail when a + ;; being-stepped definition (e.g. in a let) turns into a permanent one. + ;; We pay a terrible price for the lifting thing. And, for the fact that + ;; the highlighting follows from the reductions but can't obviously be + ;; deduced from them. + + #; + (define (highlight-mutated-expression left right) + (cond + ;; if either one is already highlighted, leave them alone. + [(or (stepper-syntax-property left 'stepper-highlight) + (stepper-syntax-property right 'stepper-highlight)) + (list left right)] + + ;; first pass: highlight if not eq?. Should be broken for local-bound + ;; things as they pass into permanence. + [(eq? left right) + (list left right)] + + [else (list (stepper-syntax-property left 'stepper-highlight) + (stepper-syntax-property right 'stepper-highlight))])) + + ;; mutated on receipt of a break, used in displaying breakpoint stuff. + (define steps-received 0) + + (define break + (lambda (mark-set break-kind [returned-value-list #f]) + + (set! steps-received (+ steps-received 1)) + ;; have to be careful else this won't be looked up right away: + ;; (commented out to allow nightly tests to proceed, 2007-09-04 + #;(when (getenv "PLTSTEPPERUNSAFE") (let ([steps-received/current steps-received]) (run-on-drscheme-side (lambda () (display-break-stuff steps-received/current mark-set break-kind returned-value-list))))) - - (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) - - (define (reconstruct-all-completed) - (filter-map - (match-lambda - [(list source-thunk lifting-indices getter) - (let ([source (source-thunk)]) - (if (r:hide-completed? source) - #f - (match (r:reconstruct-completed - source lifting-indices - getter render-settings) - [(vector exp #f) (unwind exp render-settings)] - [(vector exp #t) exp])))]) - finished-exps)) - - #;(>>> break-kind) - #;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind) - (if (r:skip-step? break-kind mark-list render-settings) + + (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) + + (define (reconstruct-all-completed) + (filter-map + (match-lambda + [(list source-thunk lifting-indices getter) + (let ([source (source-thunk)]) + (if (r:hide-completed? source) + #f + (match (r:reconstruct-completed + source lifting-indices + getter render-settings) + [(vector exp #f) (unwind exp render-settings)] + [(vector exp #t) exp])))]) + finished-exps)) + + #;(>>> break-kind) + #;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind) + (if (r:skip-step? break-kind mark-list render-settings) (begin #;(fprintf (current-error-port) " but it was skipped!\n") (when (or (eq? break-kind 'normal-break) ;; not sure about this... (eq? break-kind 'nomal-break/values)) - (set! held-exp-list skipped-step))) - + (set! held-exp-list the-skipped-step))) + (begin #;(fprintf (current-error-port) "and it wasn't skipped.\n") (case break-kind @@ -205,67 +207,73 @@ "broken invariant: normal-break can't have returned values")) (set! held-finished-list (reconstruct-all-completed)) (set! held-exp-list - (map (lambda (exp) - (unwind exp render-settings)) - (maybe-lift - (r:reconstruct-left-side - mark-list returned-value-list render-settings) - #f))) - (set! held-step-was-app? (r:step-was-app? mark-list)))] - + (make-held + (map (lambda (exp) + (unwind exp render-settings)) + (maybe-lift + (r:reconstruct-left-side + mark-list returned-value-list render-settings) + #f)) + (r:step-was-app? mark-list) + (syntax-position (mark-source (car mark-list))))))] + [(result-exp-break result-value-break) - (if (eq? held-exp-list skipped-step) - ;; don't render if before step was a skipped-step - (set! held-exp-list no-sexp) - - (let* ([new-finished-list (reconstruct-all-completed)] - [reconstructed - (map (lambda (exp) - (unwind exp render-settings)) - (maybe-lift - (r:reconstruct-right-side - mark-list returned-value-list render-settings) - #f))] - [result - (if (eq? held-exp-list no-sexp) - ;; in this case, there was no "before" step, due - ;; to unannotated code. In this case, we make the - ;; optimistic guess that none of the finished - ;; expressions were mutated. It would be somewhat - ;; painful to do a better job, and the stepper - ;; makes no guarantees in this case. - (make-before-after-result - ;; NB: this (... ...) IS UNRELATED TO - ;; THE MACRO IDIOM OF THE SAME NAME - (list #`(... ...)) - (append new-finished-list reconstructed) - 'normal) - - (let*-values - ([(step-kind) - (if (and held-step-was-app? - (eq? break-kind 'result-exp-break)) - 'user-application - 'normal)] - [(left-exps right-exps) - ;; write this later: - ;; (identify-changed - ;; (append held-finished-list held-exps) - ;; (append new-finished-list reconstructed)) - (values (append held-finished-list - held-exp-list) - (append new-finished-list - reconstructed))]) - - (make-before-after-result - left-exps right-exps step-kind)))]) - (set! held-exp-list no-sexp) - (receive-result result)))] - + (let ([reconstruct + (lambda () + (map (lambda (exp) + (unwind exp render-settings)) + (maybe-lift + (r:reconstruct-right-side + mark-list returned-value-list render-settings) + #f)))] + [send-result (lambda (result) + (set! held-exp-list the-no-sexp) + (receive-result result))]) + (match held-exp-list + [(struct skipped-step ()) + ;; don't render if before step was a skipped-step + (set! held-exp-list the-no-sexp)] + [(struct no-sexp ()) + ;; in this case, there was no "before" step, due + ;; to unannotated code. In this case, we make the + ;; optimistic guess that none of the finished + ;; expressions were mutated. It would be somewhat + ;; painful to do a better job, and the stepper + ;; makes no guarantees in this case. + (send-result + (make-before-after-result + ;; NB: this (... ...) IS UNRELATED TO + ;; THE MACRO IDIOM OF THE SAME NAME + (list #`(... ...)) + (append (reconstruct-all-completed) (reconstruct)) + 'normal + #f #f))] + [(struct held (held-exps held-step-was-app? held-source-pos)) + (let*-values + ([(step-kind) + (if (and held-step-was-app? + (eq? break-kind 'result-exp-break)) + 'user-application + 'normal)] + [(left-exps right-exps) + ;; write this later: + ;; (identify-changed + ;; (append held-finished-list held-exps) + ;; (append new-finished-list reconstructed)) + (values (append held-finished-list + held-exps) + (append (reconstruct-all-completed) + (reconstruct)))]) + + (send-result + (make-before-after-result + left-exps right-exps step-kind held-source-pos + (syntax-position (mark-source (car mark-list))))))]))] + [(double-break) ;; a double-break occurs at the beginning of a let's ;; evaluation. - (when (not (eq? held-exp-list no-sexp)) + (when (not (eq? held-exp-list the-no-sexp)) (error 'break-reconstruction "held-exp-list not empty when a double-break occurred")) @@ -273,16 +281,17 @@ [reconstruct-result (r:reconstruct-double-break mark-list render-settings)] [left-side (map (lambda (exp) (unwind exp render-settings)) - (maybe-lift (car reconstruct-result) #f))] + (maybe-lift (car reconstruct-result) #f))] [right-side (map (lambda (exp) (unwind exp render-settings)) - (maybe-lift (cadr reconstruct-result) #t))]) + (maybe-lift (cadr reconstruct-result) #t))]) ;; add highlighting code as for other cases... (receive-result (make-before-after-result (append new-finished-list left-side) (append new-finished-list right-side) - 'normal)))] - + 'normal + #f #f)))] + [(expr-finished-break) (unless (not mark-list) (error 'break @@ -294,39 +303,52 @@ (for-each (lambda (source/index/getter) (apply add-to-finished source/index/getter)) returned-value-list)] - + [else (error 'break "unknown label on break")])))))) - - (define maybe-lift - (if (render-settings-lifting? render-settings) - lift - ;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off. - (lambda (stx dont-care) (list stx)))) - - (define (step-through-expression expanded expand-next-expression) - (let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas? - language-level)]) - (parameterize ([test-engine:test-silence #t]) - (eval-syntax annotated)) - (expand-next-expression))) - - (define (err-display-handler message exn) - (if (not (eq? held-exp-list no-sexp)) - (begin - (receive-result - (make-before-error-result (append held-finished-list held-exp-list) - message)) - (set! held-exp-list no-sexp)) - (receive-result (make-error-result message)))) - - (program-expander - (lambda () - (unless disable-error-handling - (error-display-handler err-display-handler))) - (lambda (expanded continue-thunk) ; iter - (r:reset-special-values) - (if (eof-object? expanded) + + (define maybe-lift + (if (render-settings-lifting? render-settings) + lift + ;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off. + (lambda (stx dont-care) (list stx)))) + + (define (step-through-expression expanded expand-next-expression) + (let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas? + language-level)]) + (parameterize ([test-engine:test-silence #t]) + (eval-syntax annotated)) + (expand-next-expression))) + + (define (err-display-handler message exn) + (match held-exp-list + [(struct no-sexp ()) + (receive-result (make-error-result message))] + [(struct held (exps dc source-pos)) + (begin + (receive-result + (make-before-error-result (append held-finished-list exps) + message + #f + source-pos)) + (set! held-exp-list the-no-sexp))])) + + (program-expander + (lambda () + (unless disable-error-handling + (error-display-handler err-display-handler))) + (lambda (expanded continue-thunk) ; iter + (r:reset-special-values) + (if (eof-object? expanded) (begin (receive-result (make-finished-stepping))) - (step-through-expression expanded continue-thunk)))))) + (step-through-expression expanded continue-thunk))))) + +; no-sexp is used to indicate no sexpression for display. +; e.g., on an error message, there's no sexp. +(define-struct no-sexp ()) +(define the-no-sexp (make-no-sexp)) + +; skipped-step is used to indicate that the "before" step was skipped. +(define-struct skipped-step ()) +(define the-skipped-step (make-skipped-step)) \ No newline at end of file diff --git a/collects/stepper/private/mred-extensions.ss b/collects/stepper/private/mred-extensions.ss index 161a12d164..b3249003cc 100644 --- a/collects/stepper/private/mred-extensions.ss +++ b/collects/stepper/private/mred-extensions.ss @@ -3,10 +3,8 @@ mred (prefix f: framework) mzlib/pretty - "testing-shared.ss" - "shared.ss" - string-constants - mrlib/bitmap-label) + #;"testing-shared.ss" + "shared.ss") (provide foot-img/horizontal @@ -528,12 +526,6 @@ ;; the bitmap to use in a vertical toolbar: (define foot-img/vertical (make-object bitmap% (build-path (collection-path "icons") "foot-up.png") 'png/mask)) - - ;; stepper-bitmap : the image used for the stepper button - #;(define stepper-bitmap - (bitmap-label-maker - (string-constant stepper-button-label) - (build-path (collection-path "icons") "foot.png"))) ;; testing code diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index 3396094923..e62a71084d 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -173,8 +173,8 @@ (define (varref-skip-step? varref) (with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)]) (let ([val (lookup-binding mark-list varref)]) - (equal? (syntax-object->interned-datum (recon-value val render-settings)) - (syntax-object->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type) + (equal? (syntax->interned-datum (recon-value val render-settings)) + (syntax->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type) ([let-bound] (binding-lifted-name mark-list varref)) ([non-lexical] @@ -497,7 +497,7 @@ (define re:beginner: (regexp "^beginner:(.*)$")) - ;; eval-quoted : take a syntax-object that is an application of quote, and evaluate it (for display) + ;; eval-quoted : take a syntax that is an application of quote, and evaluate it (for display) ;; Frankly, I'm worried by the fact that this isn't done at expansion time. (define (eval-quoted stx) @@ -878,7 +878,7 @@ "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))])))) ; the main recursive reconstruction loop is in recon: - ; recon : (syntax-object mark-list boolean -> syntax-object) + ; recon : (syntax mark-list boolean -> syntax) (define (recon so-far mark-list first) (cond [(null? mark-list) ; now taken to indicate a callback: diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index 208f50393e..d5617d1d55 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -1,14 +1,10 @@ -(module shared mzscheme - - (require "my-macros.ss" - mzlib/contract - mzlib/list - mzlib/etc - mzlib/match - srfi/26 - mzlib/class) - - (require (for-syntax mzlib/list)) +#lang scheme + +(require "my-macros.ss" + srfi/26 + scheme/class) + +#;(require (for-syntax mzlib/list)) ; CONTRACTS @@ -36,73 +32,75 @@ [arglist->ilist (-> arglist? any)] [arglist-flatten (-> arglist? (listof identifier?))]) - (provide - skipto/auto - in-closure-table - sublist - attach-info - transfer-info - arglist->ilist - arglist-flatten - binding-set-union - binding-set-pair-union - varref-set-union - varref-set-pair-union - varref-set-remove-bindings - binding-set-varref-set-intersect - step-result? - (struct before-after-result (pre-exps post-exps kind)) - (struct before-error-result (pre-exps err-msg)) - (struct error-result (err-msg)) - (struct finished-stepping ()) - list-take - list-partition - (struct closure-record (name mark constructor? lifted-index)) - *unevaluated* - no-sexp - skipped-step - struct-flag - multiple-highlight - flatten-take - closure-table-put! - closure-table-lookup - get-lifted-var - get-arg-var - begin0-temp - zip - let-counter - syntax-pair-map - make-queue ; -> queue - queue-push ; queue val -> - queue-pop ; queue -> val - queue-length ; queue -> num - rebuild-stx ; datum syntax-object -> syntax-object - break-kind? ; predicate - varref-set? ; predicate - binding-set? ; predicate - ; get-binding-name - ; bogus-binding? - ; get-lifted-gensym - ; expr-read - ; set-expr-read! - values-map - a...b ; a list of numbers from a to b - reset-profiling-table ; profiling info - get-set-pair-union-stats ; profiling info - re-intern-identifier - finished-xml-box-table - language-level->name - - stepper-syntax-property - with-stepper-syntax-properties +(provide + skipto/auto + in-closure-table + sublist + attach-info + transfer-info + arglist->ilist + arglist-flatten + binding-set-union + binding-set-pair-union + varref-set-union + varref-set-pair-union + varref-set-remove-bindings + binding-set-varref-set-intersect + step-result? + (struct-out before-after-result) + (struct-out before-error-result) + (struct-out error-result) + (struct-out finished-stepping) + list-take + list-partition + (struct-out closure-record) + *unevaluated* + struct-flag + multiple-highlight + flatten-take + closure-table-put! + closure-table-lookup + get-lifted-var + get-arg-var + begin0-temp + zip + let-counter + syntax-pair-map + make-queue ; -> queue + queue-push ; queue val -> + queue-pop ; queue -> val + queue-length ; queue -> num + rebuild-stx ; datum syntax -> syntax + break-kind? ; predicate + varref-set? ; predicate + binding-set? ; predicate + ; get-binding-name + ; bogus-binding? + ; get-lifted-gensym + ; expr-read + ; set-expr-read! + values-map + a...b ; a list of numbers from a to b + reset-profiling-table ; profiling info + get-set-pair-union-stats ; profiling info + re-intern-identifier + finished-xml-box-table + language-level->name + + stepper-syntax-property + with-stepper-syntax-properties + + skipto/cdr + skipto/cddr + skipto/first + skipto/second + skipto/third + skipto/fourth + skipto/firstarg - skipto/cdr - skipto/cddr - skipto/first - skipto/second - skipto/third - skipto/fourth - skipto/firstarg) + view-controller^ + stepper-frame^ + ) ;; stepper-syntax-property : like syntax property, but adds properties to an association ;; list associated with the syntax property 'stepper-properties @@ -135,10 +133,10 @@ ; or (make-error-result finished-exps err-msg) ; or (make-finished-result finished-exps) - (define-struct before-after-result (pre-exps post-exps kind) (make-inspector)) - (define-struct before-error-result (pre-exps err-msg) (make-inspector)) - (define-struct error-result (err-msg) (make-inspector)) - (define-struct finished-stepping () (make-inspector)) + (define-struct before-after-result (pre-exps post-exps kind pre-src post-src) #:transparent) + (define-struct before-error-result (pre-exps err-msg pre-src) #:transparent) + (define-struct error-result (err-msg) #:transparent) + (define-struct finished-stepping () #:transparent) (define step-result? (or/c before-after-result? before-error-result? error-result? finished-stepping?)) @@ -150,7 +148,7 @@ (define (create-bogus-binding name) (let* ([gensymed-name (gensym name)] - [binding (datum->syntax-object #'here gensymed-name)]) + [binding (datum->syntax #'here gensymed-name)]) binding)) ; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings @@ -162,14 +160,14 @@ ; make-gensym-source : (string -> (key -> binding)) (define (make-binding-source id-string binding-maker key-displayer) - (let ([assoc-table (make-hash-table 'weak)]) + (let ([assoc-table (make-weak-hash)]) (lambda (key) - (let ([maybe-fetch (hash-table-get assoc-table key (lambda () #f))]) + (let ([maybe-fetch (hash-ref assoc-table key (lambda () #f))]) (or maybe-fetch (begin (let* ([new-binding (binding-maker (string-append id-string (key-displayer key) "-"))]) - (hash-table-put! assoc-table key new-binding) + (hash-set! assoc-table key new-binding) new-binding))))))) @@ -249,27 +247,21 @@ (define (next-lifted-symbol str) (let ([index lifted-index]) (set! lifted-index (+ lifted-index 1)) - (datum->syntax-object #'here (string->symbol (string-append str (number->string index)))))) + (datum->syntax #'here (string->symbol (string-append str (number->string index)))))) (define get-lifted-var (let ([assoc-table (box null)]) (lambda (stx) - (let ([maybe-fetch (weak-assoc-search assoc-table stx module-identifier=?)]) + (let ([maybe-fetch (weak-assoc-search assoc-table stx free-identifier=?)]) (or maybe-fetch (begin (let* ([new-binding (next-lifted-symbol - (string-append "lifter-" (format "~a" (syntax-object->datum stx)) "-"))]) + (string-append "lifter-" (format "~a" (syntax->datum stx)) "-"))]) (weak-assoc-add assoc-table stx new-binding) new-binding))))))) ; gensyms needed by many modules: - ; no-sexp is used to indicate no sexpression for display. - ; e.g., on an error message, there's no sexp. - (define no-sexp (gensym "no-sexp-")) - - ; skipped-step is used to indicate that the "before" step was skipped. - (define skipped-step (gensym "skipped-step-")) ; multiple-highlight is used to indicate multiple highlighted expressions (define multiple-highlight (gensym "multiple-highlight-")) @@ -306,16 +298,16 @@ (apply append (list-take n a-list))) (define-values (closure-table-put! closure-table-lookup in-closure-table) - (let ([closure-table (make-hash-table 'weak)]) + (let ([closure-table (make-weak-hash)]) (values (lambda (key value) - (hash-table-put! closure-table key value) + (hash-set! closure-table key value) key) ; this return allows a run-time-optimization (lambda args ; key or key & failure-thunk - (apply hash-table-get closure-table args)) + (apply hash-ref closure-table args)) (lambda (key) (let/ec k - (hash-table-get closure-table key (lambda () (k #f))) + (hash-ref closure-table key (lambda () (k #f))) #t))))) ;(begin (closure-table-put! 'foo 'bar) @@ -395,7 +387,7 @@ (length (unbox queue))) (define (rebuild-stx new old) - (syntax-recertify (datum->syntax-object old new old old) + (syntax-recertify (datum->syntax old new old old) old (current-code-inspector) #f)) @@ -472,9 +464,9 @@ (define skipto/fourth `(syntax-e cdr cdr cdr car)) (define skipto/firstarg (append skipto/cdr skipto/second)) - ;; skipto/auto : syntax-object? + ;; skipto/auto : syntax? ;; (symbols 'rebuild 'discard) - ;; (syntax-object? . -> . syntax-object?) + ;; (syntax? . -> . syntax?) ;; "skips over" part of a tree to find a subtree indicated by the ;; stepper-skipto property. If the traversal argument is 'rebuild, the ;; result of transformation is embedded again in the same tree. if the @@ -488,7 +480,7 @@ [else (transformer stx)])) ; small test case: - #;(display (equal? (syntax-object->datum + #;(display (equal? (syntax->datum (skipto/auto (stepper-syntax-property #`(a #,(stepper-syntax-property #`(b c) 'stepper-skipto '(syntax-e cdr car))) @@ -509,12 +501,12 @@ ; binding-set-union: (listof BINDING-SET) -> BINDING-SET ; varref-set-union: (listof VARREF-SET) -> VARREF-SET - (define profiling-table (make-hash-table 'equal)) + (define profiling-table (make-hash)) (define (reset-profiling-table) - (set! profiling-table (make-hash-table 'equal))) + (set! profiling-table (make-hash))) (define (get-set-pair-union-stats) - (hash-table-map profiling-table (lambda (k v) (list k (unbox v))))) + (hash-map profiling-table (lambda (k v) (list k (unbox v))))) ;; test cases : ;; (profiling-table-incr 1 2) @@ -623,12 +615,10 @@ #`#,(string->symbol (symbol->string (syntax-e identifier)))) - (provide/contract [syntax-object->hilite-datum ((syntax?) ; input - (boolean?) ; ignore-highlight? - . opt-> . - any/c)]) ; sexp with explicit tags + (provide/contract [syntax->hilite-datum + ((syntax?) (#:ignore-highlight? boolean?) . ->* . any)]) ; sexp with explicit tags - ;; syntax-object->hilite-datum : takes a syntax object with zero or more + ;; syntax->hilite-datum : takes a syntax object with zero or more ;; subexpressions tagged with the 'stepper-highlight', 'stepper-xml-hint', and 'stepper-xml-value-hint' syntax-properties ;; and turns it into a datum, where expressions with the named ;; properties result in (hilite ), (xml-box ), (scheme-box ) and (splice-box ) rather than . It also @@ -637,52 +627,51 @@ ;; ;; this procedure is useful in checking the output of the stepper. - (define syntax-object->hilite-datum - (opt-lambda (stx [ignore-highlight? #f]) - (let ([datum (syntax-case stx () - [(a . rest) (cons (syntax-object->hilite-datum #`a) (syntax-object->hilite-datum #`rest))] - [id - (identifier? stx) - (string->symbol (symbol->string (syntax-e stx)))] - [else (if (syntax? stx) - (syntax-object->datum stx) - stx)])]) - (let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint) - [(from-xml-box) `(xml-box ,datum)] - [(from-scheme-box) `(scheme-box ,datum)] - [(from-splice-box) `(splice-box ,datum)] - [else datum])] - [it (case (stepper-syntax-property stx 'stepper-xml-value-hint) - [(from-xml-box) `(xml-box-value ,it)] - [else it])] - [it (if (and (not ignore-highlight?) - (stepper-syntax-property stx 'stepper-highlight)) - `(hilite ,it) - it)]) - it)))) + (define (syntax->hilite-datum stx #:ignore-highlight? [ignore-highlight? #f]) + (let ([datum (syntax-case stx () + [(a . rest) (cons (syntax->hilite-datum #`a) (syntax->hilite-datum #`rest))] + [id + (identifier? stx) + (string->symbol (symbol->string (syntax-e stx)))] + [else (if (syntax? stx) + (syntax->datum stx) + stx)])]) + (let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint) + [(from-xml-box) `(xml-box ,datum)] + [(from-scheme-box) `(scheme-box ,datum)] + [(from-splice-box) `(splice-box ,datum)] + [else datum])] + [it (case (stepper-syntax-property stx 'stepper-xml-value-hint) + [(from-xml-box) `(xml-box-value ,it)] + [else it])] + [it (if (and (not ignore-highlight?) + (stepper-syntax-property stx 'stepper-highlight)) + `(hilite ,it) + it)]) + it))) ;; finished-xml-box-table : this table tracks values that are the result ;; of evaluating xml boxes. These values should be rendered as xml boxes, ;; and not as simple lists. - (define finished-xml-box-table (make-hash-table 'weak)) + (define finished-xml-box-table (make-weak-hash)) - (provide/contract [syntax-object->interned-datum (syntax? ; input + (provide/contract [syntax->interned-datum (syntax? ; input . -> . any)]) ; sexp - ;; syntax-object->interned-datum : like syntax-object->datum, except + ;; syntax->interned-datum : like syntax->datum, except ;; that it re-interns all identifiers. Useful in checking whether ;; two sexps will have the same printed representation. - (define (syntax-object->interned-datum stx) + (define (syntax->interned-datum stx) (syntax-case stx () - [(a . rest) (cons (syntax-object->interned-datum #`a) (syntax-object->interned-datum #`rest))] + [(a . rest) (cons (syntax->interned-datum #`a) (syntax->interned-datum #`rest))] [id (identifier? stx) (string->symbol (symbol->string (syntax-e stx)))] [else (if (syntax? stx) - (syntax-object->datum stx) + (syntax->datum stx) stx)])) @@ -727,7 +716,11 @@ (define (language-level->name language) (car (last-pair (send language get-language-position)))) - ) + + + (define-signature view-controller^ (go)) + (define-signature stepper-frame^ (stepper-frame%)) + ; test cases @@ -736,12 +729,12 @@ ;(load (build-path (collection-path "tests" "mzscheme") "testing.ss")) ; ;(define (a sym) -; (syntax-object->datum (get-lifted-var sym))) +; (syntax->datum (get-lifted-var sym))) ;(define cd-stx -; (datum->syntax-object #f 'cd)) -;(test 'lifter-ab-0 a (datum->syntax-object #f 'ab)) +; (datum->syntax #f 'cd)) +;(test 'lifter-ab-0 a (datum->syntax #f 'ab)) ;(test 'lifter-cd-1 a cd-stx) -;(test 'lifter-ef-2 a (datum->syntax-object #f 'ef)) +;(test 'lifter-ef-2 a (datum->syntax #f 'ef)) ;(test 'lifter-cd-1 a cd-stx) ; ;(test '(a b c) map syntax-e (arglist->ilist #'(a b c))) @@ -786,5 +779,6 @@ ;(test 'yes stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'abc) ;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'no) 'abc 'yes) 'abc) ;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg) 'abc) -;(test 13 syntax-object->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg)) +;(test 13 syntax->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg)) + diff --git a/collects/stepper/stepper+xml-tool.ss b/collects/stepper/stepper+xml-tool.ss index bf34fbe4bd..6a13023fc2 100644 --- a/collects/stepper/stepper+xml-tool.ss +++ b/collects/stepper/stepper+xml-tool.ss @@ -2,7 +2,9 @@ (require mzlib/unit drscheme/tool "stepper-tool.ss" - "xml-tool.ss") + "xml-tool.ss" + "view-controller.ss" + "private/shared.ss") (provide tool@) @@ -19,4 +21,5 @@ (import drscheme:tool^) (export STEPPER-TOOL) (link xml-tool@ - (((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@))))) + view-controller@ + [((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@])))) diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index b50b7ecfbd..564d3b24a6 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -1,719 +1,384 @@ -(module stepper-tool mzscheme +#lang scheme/unit - (require mzlib/contract - drscheme/tool - mred - mzlib/pconvert - string-constants - mzlib/async-channel - (prefix frame: framework) - mzlib/unit - mzlib/class - mzlib/list - mrlib/switchable-button - (prefix model: "private/model.ss") - "private/my-macros.ss" - (prefix x: "private/mred-extensions.ss") - "private/shared.ss" - "private/model-settings.ss" - lang/stepper-language-interface - "xml-sig.ss") +(require scheme/class + drscheme/tool + mred + mzlib/pconvert + string-constants + (prefix-in frame: framework) + mrlib/switchable-button + "private/my-macros.ss" + (prefix-in x: "private/mred-extensions.ss") + "private/shared.ss" + lang/stepper-language-interface + "xml-sig.ss") - (provide stepper-tool@ - make-print-convert-hook - set-print-settings - simple-module-based-language-convert-value) - - (define-unit stepper-tool@ - (import drscheme:tool^ xml^) - (export drscheme:tool-exports^) - - ;; tool magic here: - (define (phase1) - - ;; experiment with extending the language... parameter-like fields for stepper parameters - (drscheme:language:extend-language-interface - stepper-language<%> - (lambda (superclass) - (class* superclass (stepper-language<%>) - (public stepper:supported?) - (define (stepper:supported?) #f) - (public stepper:enable-let-lifting?) - (define (stepper:enable-let-lifting?) #f) - (public stepper:show-lambdas-as-lambdas?) - (define (stepper:show-lambdas-as-lambdas?) #t) - (public stepper:render-to-sexp) - (define (stepper:render-to-sexp val settings language-level) - (parameterize ([current-print-convert-hook - (make-print-convert-hook settings)]) - (set-print-settings - language-level - settings - (lambda () - (simple-module-based-language-convert-value - val - (drscheme:language:simple-settings-printing-style settings) - (drscheme:language:simple-settings-show-sharing settings)))))) - - (super-instantiate ()))))) - - (define (phase2) (void)) - - ;; this should be a preference: - (define stepper-initial-width 500) - (define stepper-initial-height 500) - - (define drscheme-eventspace (current-eventspace)) - - (define (extract-language-level definitions-text) - (settings->language-level (definitions-text->settings definitions-text))) - - (define (definitions-text->settings definitions-text) - (send definitions-text get-next-settings)) - - (define (settings->language-level settings) - (drscheme:language-configuration:language-settings-language settings)) - - (define (stepper-works-for? language-level) - (or (send language-level stepper:supported?) - (getenv "PLTSTEPPERUNSAFE"))) - - ;; the stepper's frame: - - (define stepper-frame% - (class (drscheme:frame:basics-mixin - (frame:frame:standard-menus-mixin frame:frame:basic%)) - - (init-field drscheme-frame) - - ;; PRINTING-PROC - ;; I frankly don't think that printing (i.e., to a printer) works - ;; correctly. 2005-07-01, JBC - (public set-printing-proc) - - (define (set-printing-proc proc) - (set! printing-proc proc)) - - (define (printing-proc item evt) - (message-box "error?" "shouldn't be called")) - - (define/private (file-menu:print a b) (printing-proc a b)) - - ;; MENUS - - (define/override (edit-menu:between-find-and-preferences edit-menu) - (void)) - (define/override (edit-menu:between-select-all-and-find edit-menu) - (void)) - (define/override (file-menu:between-save-as-and-print file-menu) - (void)) - - ;; CUSTODIANS - ;; The custodian is used to halt the stepped computation when the - ;; stepper window closes. The custodian is captured when the stepped - ;; computation starts. - - (define custodian #f) - (define/public (set-custodian! cust) - (set! custodian cust)) - (define/augment (on-close) - (when custodian - (custodian-shutdown-all custodian)) - (send drscheme-frame on-stepper-close) - (inner (void) on-close)) - - ;; WARNING BOXES: - - (define program-changed-warning-str - (string-constant stepper-program-has-changed)) - (define window-closed-warning-str - (string-constant stepper-program-window-closed)) - - (define warning-message-visible-already #f) - (define/private (add-warning-message warning-str) - (let ([warning-msg (new x:stepper-warning% - [warning-str warning-str] - [parent (get-area-container)])]) - (send (get-area-container) - change-children - (if warning-message-visible-already - (lambda (l) - (list (car l) warning-msg (caddr l))) - (lambda (l) - (list (car l) warning-msg (cadr l))))) - (set! warning-message-visible-already #t))) - - (inherit get-area-container) - (define program-change-already-warned? #f) - (define/public (original-program-changed) - (unless program-change-already-warned? - (set! program-change-already-warned? #t) - (add-warning-message program-changed-warning-str))) - - (define/public (original-program-gone) - (add-warning-message window-closed-warning-str)) - - (super-new [label "Stepper"] [parent #f] - [width stepper-initial-width] - [height stepper-initial-height]))) - - ;; view-controller-go: called when the stepper starts; starts the - ;; stepper's view&controller - ;; drscheme-frame : the drscheme frame which is starting the stepper - ;; program-expander : see "model.ss" for the contract on a - ;; program-expander - ;; -> returns the new frame% - - (define (view-controller-go drscheme-frame program-expander) - - ;; get the language-level name: - (define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) - (define language-level - (settings->language-level language-settings)) - (define language-level-name - (language-level->name language-level)) - - ;; VALUE CONVERSION CODE: - - (define simple-settings - (drscheme:language-configuration:language-settings-settings - language-settings)) - - ;; render-to-string : TST -> string - (define (render-to-string val) - (let ([string-port (open-output-string)]) - (send language-level render-value val simple-settings string-port) - (get-output-string string-port))) - - ;; render-to-sexp : TST -> sexp - (define (render-to-sexp val) - (send language-level stepper:render-to-sexp val simple-settings language-level)) - - ;; channel for incoming views - (define view-channel (make-async-channel)) - - ;; the semaphore associated with the view at the end of the - ;; view-history note that because these are fresh semaphores for every - ;; step, posting to a semaphore multiple times is no problem. - (define release-for-next-step #f) - - ;; the list of available views - (define view-history null) - - ;; the view in the stepper window - (define view 0) - - ;; whether the stepper is waiting for a new view to become available - ;; (initially 'waiting-for-any-step) - ;; possible values: #f, 'waiting-for-any-step, 'waiting-for-application, 'waiting-for-end - (define stepper-is-waiting? 'waiting-for-any-step) - - ;; hand-off-and-block : (-> text%? boolean? void?) - ;; hand-off-and-block generates a new semaphore, hands off a thunk to - ;; drscheme's eventspace, and blocks on the new semaphore. The thunk - ;; adds the text% to the waiting queue, and checks to see if the - ;; stepper is waiting for a new step. If so, takes that new text% out - ;; of the queue and puts it on the list of available ones. If the - ;; stepper is waiting for a new step, it checks to see whether this is - ;; of the kind that the stepper wants. If so, display it. otherwise, - ;; release the stepped program to continue execution. - (define (hand-off-and-block step-text step-kind) - (let ([new-semaphore (make-semaphore)]) - (run-on-drscheme-side - (lambda () - (async-channel-put view-channel - (list step-text new-semaphore step-kind)) - (when stepper-is-waiting? - (let ([try-get (async-channel-try-get view-channel)]) - (unless try-get - (error - 'check-for-stepper-waiting - "queue is empty, even though a step was just added")) - (add-view-triple try-get) - (if (right-kind-of-step? (caddr try-get)) - ;; got the desired step; show the user: - (begin (set! stepper-is-waiting? #f) - (update-view/existing (- (length view-history) 1))) - ;; nope, keep running: - (begin (en/dis-able-buttons) - (semaphore-post new-semaphore))))))) - (semaphore-wait new-semaphore))) - - ;; run-on-drscheme-side : runs a thunk in the drscheme eventspace. - ;; Passed to 'go' so that display-break-stuff can work. This would be - ;; cleaner with two-way provides. - (define (run-on-drscheme-side thunk) - (parameterize ([current-eventspace drscheme-eventspace]) - (queue-callback thunk))) - - ;; right-kind-of-step? : (boolean? . -> . boolean?) - ;; is this step the kind of step that the gui is waiting for? - (define (right-kind-of-step? step-kind) - (case stepper-is-waiting? - [(waiting-for-any-step) #t] - [(waiting-for-application) - (or (eq? step-kind 'user-application) - (eq? step-kind 'finished-stepping))] - [(waiting-for-end) - (or (eq? step-kind 'finished-stepping))] - [(#f) (error 'right-kind-of-step - "this code should be unreachable with stepper-is-waiting? set to #f")] - [else (error 'right-kind-of-step - "unknown value for stepper-is-waiting?: ~a" - stepper-is-waiting?)])) - - ;; add-view-triple : set the release-semaphore to be the new one, add - ;; the view to the list. - (define (add-view-triple view-triple) - (set! release-for-next-step (cadr view-triple)) - (set! view-history (append view-history - (list (list (car view-triple) - (caddr view-triple)))))) - - ;; find-later-step : given a predicate on history-entries, search through - ;; the history for the first step that satisfies the predicate and whose - ;; number is greater than n - (define (find-later-step p n) - (let loop ([step 0] - [remaining view-history]) - (cond [(null? remaining) #f] - [(and (> step n) (p (car remaining))) step] - [else (loop (+ step 1) (cdr remaining))]))) - - (define (find-later-application-step n) - (find-later-step application-step? n)) - - (define (find-later-finished-stepping-step n) - (find-later-step finished-stepping-step? n)) - - (define (find-later-any-step n) - (find-later-step (lambda (x) #t) n)) - - ;; is this an application step? - (define (application-step? history-entry) - (case (cadr history-entry) - [(user-application finished-stepping) #t] - [else #f])) - - ;; is this the finished-stepping step? - (define (finished-stepping-step? history-entry) - (case (cadr history-entry) - [(finished-stepping) #t] - [else #f])) - - ;; build gui object: - - ;; home : the action of the 'home' button - (define (home) - (set! stepper-is-waiting? #f) - (update-view/existing 0)) - - ;; next-of-specified-kind: if the desired step is already in the list, display - ;; it; otherwise, wait for it. - (define (next-of-specified-kind find-step right-kind? wait-for-it-flag) - (set! stepper-is-waiting? #f) - (let ([found-step (find-step view)]) - (if found-step - (update-view/existing found-step) - (begin - ;; each step has its own semaphore, so releasing one twice is - ;; no problem. - (semaphore-post release-for-next-step) - (when stepper-is-waiting? - (error 'try-to-get-view - "try-to-get-view should not be reachable when already waiting for new step")) - (let ([try-get (async-channel-try-get view-channel)]) - (when try-get - (add-view-triple try-get)) - (if (and try-get (right-kind? (list-ref view-history (+ view 1)))) - (update-view/existing (+ view 1)) - (begin - (set! stepper-is-waiting? wait-for-it-flag) - (en/dis-able-buttons)))))))) - - ;; respond to a click on the "next" button - (define (next) - (next-of-specified-kind find-later-any-step - (lambda (x) #t) - 'waiting-for-any-step)) - - ;; respond to a click on the "next application" button - (define (next-application) - (next-of-specified-kind find-later-application-step - application-step? - 'waiting-for-application)) - - ;; respond to a click on the "jump to end" button - (define (jump-to-end) - (next-of-specified-kind find-later-finished-stepping-step - finished-stepping-step? - 'waiting-for-end)) - - ;; previous : the action of the 'previous' button - (define (previous) - (set! stepper-is-waiting? #f) - (when (= view 0) - (error 'previous-application - "previous-step button should not be enabled in view zero.")) - (update-view/existing (- view 1))) - - ;; previous-application : the action of the 'previous-application' - ;; button - (define (previous-application) - (set! stepper-is-waiting? #f) - (when (= view 0) - (error 'previous-application - "previous-application button should not be enabled in view zero.")) - (let loop ([new-view (- view 1)]) - (cond [(= new-view 0) - (update-view/existing new-view)] - [(application-step? (list-ref view-history new-view)) - (update-view/existing new-view)] - [else (loop (sub1 new-view))]))) - - ;; GUI ELEMENTS: - (define s-frame - (make-object stepper-frame% drscheme-frame)) - (define button-panel - (make-object horizontal-panel% (send s-frame get-area-container))) - (define (add-button name fun) - (make-object button% name button-panel (lambda (_1 _2) (fun)))) - - (define home-button (add-button (string-constant stepper-home) home)) - (define previous-application-button (add-button (string-constant stepper-previous-application) previous-application)) - (define previous-button (add-button (string-constant stepper-previous) previous)) - (define next-button (add-button (string-constant stepper-next) next)) - (define next-application-button (add-button (string-constant stepper-next-application) next-application)) - (define jump-to-end-button (add-button (string-constant stepper-jump-to-end) jump-to-end)) - - (define canvas - (make-object x:stepper-canvas% (send s-frame get-area-container))) - - ;; update-view/existing : set an existing step as the one shown in the - ;; frame - (define (update-view/existing new-view) - (set! view new-view) - (let ([e (car (list-ref view-history view))]) - (send e begin-edit-sequence) - (send canvas set-editor e) - (send e reset-width canvas) - (send e set-position (send e last-position)) - (send e end-edit-sequence)) - (en/dis-able-buttons)) - - ;; en/dis-able-buttons : set enable & disable the stepper buttons, - ;; based on view-controller state - (define (en/dis-able-buttons) - (let* ([can-go-back? (> view 0)]) - (send previous-button enable can-go-back?) - (send previous-application-button enable can-go-back?) - (send home-button enable can-go-back?) - (send next-button - enable (or (find-later-any-step view) - (not stepper-is-waiting?))) - (send next-application-button - enable (or (find-later-application-step view) - (not stepper-is-waiting?))) - (send jump-to-end-button - enable (or (find-later-finished-stepping-step view) - (not stepper-is-waiting?))))) - - (define (print-current-view item evt) - (send (send canvas get-editor) print)) - - ;; receive-result takes a result from the model and renders it - ;; on-screen. Runs on the user thread. - ;; : (step-result -> void) - (define (receive-result result) - (let ([step-text - (cond [(before-after-result? result) - (new x:stepper-text% - [left-side (before-after-result-pre-exps result)] - [right-side (before-after-result-post-exps result)])] - [(before-error-result? result) - (new x:stepper-text% - [left-side (before-error-result-pre-exps result)] - [right-side (before-error-result-err-msg result)])] - [(error-result? result) - (new x:stepper-text% - [left-side null] - [right-side (error-result-err-msg result)])] - [(finished-stepping? result) - x:finished-text])] - [step-kind (or (and (before-after-result? result) - (before-after-result-kind result)) - (and (finished-stepping? result) - 'finished-stepping))]) - (hand-off-and-block step-text step-kind))) - - ;; need to capture the custodian as the thread starts up: - (define (program-expander-prime init iter) - (program-expander - (lambda args - (send s-frame set-custodian! (current-custodian)) - (apply init args)) - iter)) - - ;; CONFIGURE GUI ELEMENTS - (send s-frame set-printing-proc print-current-view) - (send button-panel stretchable-width #f) - (send button-panel stretchable-height #f) - (send canvas stretchable-height #t) - (en/dis-able-buttons) - (send (send s-frame edit-menu:get-undo-item) enable #f) - (send (send s-frame edit-menu:get-redo-item) enable #f) - - ;; START THE MODEL - (model:go - program-expander-prime receive-result - (get-render-settings render-to-string render-to-sexp - (send language-level stepper:enable-let-lifting?)) - (send language-level stepper:show-lambdas-as-lambdas?) - language-level - run-on-drscheme-side - #f) - (send s-frame show #t) - - s-frame) - - ;; stepper-unit-frame<%> : the interface that the extended drscheme frame - ;; fulfils - (define stepper-unit-frame<%> - (interface () - get-stepper-frame - on-stepper-close)) - - ;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme - ;; frame to interact with a possible stepper window - (define (stepper-unit-frame-mixin super%) - (class* super% (stepper-unit-frame<%>) - - (inherit get-button-panel register-toolbar-button get-interactions-text get-definitions-text) - - (define stepper-frame #f) - (define/public (on-stepper-close) - (set! stepper-frame #f)) - (define/public (get-stepper-frame) stepper-frame) - - (super-new) - - ;; program-expander : produces expanded expressions from the - ;; definitions window one at a time and calls 'iter' on each one - (define (program-expander init iter) - (let* ([lang-settings - (send (get-definitions-text) get-next-settings)] - [lang (drscheme:language-configuration:language-settings-language lang-settings)] - [settings (drscheme:language-configuration:language-settings-settings lang-settings)]) - (drscheme:eval:expand-program - (drscheme:language:make-text/pos - (get-definitions-text) - 0 - (send (get-definitions-text) last-position)) - lang-settings - #f - (lambda () - (init) - (error-value->string-handler - (lambda (val len) - (let ([sp (open-output-string)]) - (send lang render-value val settings sp) - (let ([str (get-output-string sp)]) - (if ((string-length str) . <= . len) - str - (string-append (substring str 0 (max 0 (- len 3))) - "...")))))) - (current-print void)) - void ; kill - iter))) - - ;; STEPPER BUTTON - - (define/public (get-stepper-button) stepper-button) - - (define stepper-button-parent-panel - (new horizontal-panel% - [parent (get-button-panel)] - [stretchable-width #f] - [stretchable-height #f])) - - (define stepper-button - (new switchable-button% - [parent stepper-button-parent-panel] - [label (string-constant stepper-button-label)] - [bitmap x:foot-img/horizontal] - [alternate-bitmap x:foot-img/vertical] - [callback (lambda (button) - (if stepper-frame - (send stepper-frame show #t) - (let* ([language-level - (extract-language-level (get-definitions-text))] - [language-level-name (language-level->name language-level)]) - (if (stepper-works-for? language-level) - (set! stepper-frame - (view-controller-go this program-expander)) - (message-box - (string-constant stepper-name) - (format (string-constant stepper-language-level-message) - language-level-name))))))])) - - (register-toolbar-button stepper-button) - - (define/augment (enable-evaluation) - (send stepper-button enable #t) - (inner (void) enable-evaluation)) - - (define/augment (disable-evaluation) - (send stepper-button enable #f) - (inner (void) disable-evaluation)) - - (define/augment (on-close) - (when stepper-frame - (send stepper-frame original-program-gone)) - (inner (void) on-close)) - - (define/augment (on-tab-change old new) - (check-current-language-for-stepper) - (inner (void) on-tab-change old new)) - - (define/public (check-current-language-for-stepper) - (if (stepper-works-for? - (extract-language-level (get-definitions-text))) - (unless (send stepper-button is-shown?) - (send (send stepper-button get-parent) - add-child stepper-button)) - (when (send stepper-button is-shown?) - (send (send stepper-button get-parent) - delete-child stepper-button)))) - - ;; add the stepper button to the button panel: - (send (get-button-panel) change-children - (lx (cons stepper-button-parent-panel - (remq stepper-button-parent-panel _)))) - - ;; hide stepper button if it's not supported for the initial language: - (check-current-language-for-stepper))) - - ;; stepper-definitions-text-mixin : a mixin for the definitions text that - ;; alerts thet stepper when the definitions text is altered or destroyed - (define (stepper-definitions-text-mixin %) - (class % - - (inherit get-top-level-window) - (define/private (notify-stepper-frame-of-change) - (let ([win (get-top-level-window)]) - ;; should only be #f when win is #f - (when (is-a? win stepper-unit-frame<%>) - (let ([stepper-window (send win get-stepper-frame)]) - (when stepper-window - (send stepper-window original-program-changed)))))) - - (define/augment (on-insert x y) - (unless metadata-changing-now? - (notify-stepper-frame-of-change)) - (inner (void) on-insert x y)) - - (define/augment (on-delete x y) - (unless metadata-changing-now? - (notify-stepper-frame-of-change)) - (inner (void) on-delete x y)) - - (define/augment (after-set-next-settings s) - (let ([tlw (get-top-level-window)]) - (when tlw - (send tlw check-current-language-for-stepper))) - (inner (void) after-set-next-settings s)) - - (define metadata-changing-now? #f) - - ;; don't pay attention to changes that occur on metadata. - ;; this assumes that metadata changes cannot be nested. - (define/augment (begin-metadata-changes) - (set! metadata-changing-now? #t) - (inner (void) begin-metadata-changes)) - - (define/augment (end-metadata-changes) - (set! metadata-changing-now? #f) - (inner (void) end-metadata-changes)) - - (super-new))) - - ;; apply the mixins dynamically to the drscheme unit frame and - ;; definitions text: - (drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin) - (drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin) - - ) - - ;; COPIED FROM drscheme/private/language.ss - ;; simple-module-based-language-convert-value : TST STYLE boolean -> TST - (define (simple-module-based-language-convert-value value style show-sharing?) - (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) - (if (or (is-a? expr snip%) - ;; FIXME: internal in language.ss (to-snip-value? expr) - ) - expr - (sh expr basic-convert sub-convert))) - ;; mflatt: MINOR HACK - work around temporary - ;; print-convert problems - (define (stepper-print-convert v) - (or (and (procedure? v) (object-name v)) - (print-convert v))) - - (case style - [(write) value] - [(current-print) value] - [(constructor) - (parameterize - ([constructor-style-printing #t] - [show-sharing show-sharing?] - [current-print-convert-hook - (leave-snips-alone-hook (current-print-convert-hook))]) - (stepper-print-convert value))] - [(quasiquote) - (parameterize - ([constructor-style-printing #f] - [show-sharing show-sharing?] - [current-print-convert-hook - (leave-snips-alone-hook (current-print-convert-hook))]) - (stepper-print-convert value))] - [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) - - ;; set-print-settings ; settings ( -> TST) -> TST - (define (set-print-settings language simple-settings thunk) - (if (method-in-interface? 'set-printing-parameters (object-interface language)) - (send language set-printing-parameters simple-settings thunk) - ;; assume that the current print-convert context is fine - ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") - (thunk))) - - ;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC) +(import drscheme:tool^ xml^ view-controller^) +(export drscheme:tool-exports^ stepper-frame^) - ;; make-print-convert-hook: - ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) - ;; this code copied from various locations in language.ss and rep.ss - (define (make-print-convert-hook simple-settings) - (lambda (exp basic-convert sub-convert) - (cond - [(is-a? exp snip%) - (send exp copy)] - #; - [((drscheme:rep:use-number-snip) exp) - (let ([number-snip-type - (drscheme:language:simple-settings-fraction-style - simple-settings)]) - (cond - [(eq? number-snip-type 'repeating-decimal) - (drscheme:number-snip:make-repeating-decimal-snip exp #f)] - [(eq? number-snip-type 'repeating-decimal-e) - (drscheme:number-snip:make-repeating-decimal-snip exp #t)] - [(eq? number-snip-type 'mixed-fraction) - (drscheme:number-snip:make-fraction-snip exp #f)] - [(eq? number-snip-type 'mixed-fraction-e) - (drscheme:number-snip:make-fraction-snip exp #t)] - [else - (error 'which-number-snip - "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e" - number-snip-type)]))] - [else (basic-convert exp)]))) + ;; tool magic here: +(define (phase1) + + ;; experiment with extending the language... parameter-like fields for stepper parameters + (drscheme:language:extend-language-interface + stepper-language<%> + (lambda (superclass) + (class* superclass (stepper-language<%>) + (public stepper:supported?) + (define (stepper:supported?) #f) + (public stepper:enable-let-lifting?) + (define (stepper:enable-let-lifting?) #f) + (public stepper:show-lambdas-as-lambdas?) + (define (stepper:show-lambdas-as-lambdas?) #t) + (public stepper:render-to-sexp) + (define (stepper:render-to-sexp val settings language-level) + (parameterize ([current-print-convert-hook stepper-print-convert-hook]) + (set-print-settings + language-level + settings + (lambda () + (simple-module-based-language-convert-value + val + (drscheme:language:simple-settings-printing-style settings) + (drscheme:language:simple-settings-show-sharing settings)))))) + + (super-instantiate ()))))) + +(define (phase2) (void)) + +;; this should be a preference: +(define stepper-initial-width 500) +(define stepper-initial-height 500) + +(define (extract-language-level definitions-text) + (settings->language-level (definitions-text->settings definitions-text))) + +(define (definitions-text->settings definitions-text) + (send definitions-text get-next-settings)) + +(define (settings->language-level settings) + (drscheme:language-configuration:language-settings-language settings)) + +(define (stepper-works-for? language-level) + (or (send language-level stepper:supported?) + (getenv "PLTSTEPPERUNSAFE"))) + + ;; the stepper's frame: + + (define stepper-frame% + (class (drscheme:frame:basics-mixin + (frame:frame:standard-menus-mixin frame:frame:basic%)) + + (init-field drscheme-frame) + + ;; PRINTING-PROC + ;; I frankly don't think that printing (i.e., to a printer) works + ;; correctly. 2005-07-01, JBC + (public set-printing-proc) + + (define (set-printing-proc proc) + (set! printing-proc proc)) + + (define (printing-proc item evt) + (message-box "error?" "shouldn't be called")) + + (define/private (file-menu:print a b) (printing-proc a b)) + + ;; MENUS + + (define/override (edit-menu:between-find-and-preferences edit-menu) + (void)) + (define/override (edit-menu:between-select-all-and-find edit-menu) + (void)) + (define/override (file-menu:between-save-as-and-print file-menu) + (void)) + + ;; CUSTODIANS + ;; The custodian is used to halt the stepped computation when the + ;; stepper window closes. The custodian is captured when the stepped + ;; computation starts. + + (define custodian #f) + (define/public (set-custodian! cust) + (set! custodian cust)) + (define/augment (on-close) + (when custodian + (custodian-shutdown-all custodian)) + (send drscheme-frame on-stepper-close) + (inner (void) on-close)) + + ;; WARNING BOXES: + + (define program-changed-warning-str + (string-constant stepper-program-has-changed)) + (define window-closed-warning-str + (string-constant stepper-program-window-closed)) + + (define warning-message-visible-already #f) + (define/private (add-warning-message warning-str) + (let ([warning-msg (new x:stepper-warning% + [warning-str warning-str] + [parent (get-area-container)])]) + (send (get-area-container) + change-children + (if warning-message-visible-already + (lambda (l) + (list (car l) warning-msg (caddr l))) + (lambda (l) + (list (car l) warning-msg (cadr l))))) + (set! warning-message-visible-already #t))) + + (inherit get-area-container) + (define program-change-already-warned? #f) + (define/public (original-program-changed) + (unless program-change-already-warned? + (set! program-change-already-warned? #t) + (add-warning-message program-changed-warning-str))) + + (define/public (original-program-gone) + (add-warning-message window-closed-warning-str)) + + (super-new [label "Stepper"] [parent #f] + [width stepper-initial-width] + [height stepper-initial-height]))) + + + ;; stepper-unit-frame<%> : the interface that the extended drscheme frame + ;; fulfils + (define stepper-unit-frame<%> + (interface () + get-stepper-frame + on-stepper-close)) + + ;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme + ;; frame to interact with a possible stepper window + (define (stepper-unit-frame-mixin super%) + (class* super% (stepper-unit-frame<%>) + + (inherit get-button-panel register-toolbar-button get-interactions-text get-definitions-text) + + (define stepper-frame #f) + (define/public (on-stepper-close) + (set! stepper-frame #f)) + (define/public (get-stepper-frame) stepper-frame) + + (super-new) + + ;; program-expander : produces expanded expressions from the + ;; definitions window one at a time and calls 'iter' on each one + (define (program-expander init iter) + (let* ([lang-settings + (send (get-definitions-text) get-next-settings)] + [lang (drscheme:language-configuration:language-settings-language lang-settings)] + [settings (drscheme:language-configuration:language-settings-settings lang-settings)]) + (drscheme:eval:expand-program + (drscheme:language:make-text/pos + (get-definitions-text) + 0 + (send (get-definitions-text) last-position)) + lang-settings + #f + (lambda () + (init) + (error-value->string-handler + (lambda (val len) + (let ([sp (open-output-string)]) + (send lang render-value val settings sp) + (let ([str (get-output-string sp)]) + (if ((string-length str) . <= . len) + str + (string-append (substring str 0 (max 0 (- len 3))) + "...")))))) + (current-print void)) + void ; kill + iter))) + + ;; STEPPER BUTTON + + (define/public (get-stepper-button) stepper-button) + + (define stepper-button-parent-panel + (new horizontal-panel% + [parent (get-button-panel)] + [stretchable-width #f] + [stretchable-height #f])) + + (define stepper-button + (new switchable-button% + [parent stepper-button-parent-panel] + [label (string-constant stepper-button-label)] + [bitmap x:foot-img/horizontal] + [alternate-bitmap x:foot-img/vertical] + [callback (lambda (dont-care) + (if stepper-frame + (send stepper-frame show #t) + (let* ([language-level + (extract-language-level (get-definitions-text))] + [language-level-name (language-level->name language-level)]) + (if (stepper-works-for? language-level) + (set! stepper-frame + (go this + program-expander + (+ 1 (send (get-definitions-text) get-start-position)))) + (message-box + (string-constant stepper-name) + (format (string-constant stepper-language-level-message) + language-level-name))))))])) + + (register-toolbar-button stepper-button) + + (define/augment (enable-evaluation) + (send stepper-button enable #t) + (inner (void) enable-evaluation)) + + (define/augment (disable-evaluation) + (send stepper-button enable #f) + (inner (void) disable-evaluation)) + + (define/augment (on-close) + (when stepper-frame + (send stepper-frame original-program-gone)) + (inner (void) on-close)) + + (define/augment (on-tab-change old new) + (check-current-language-for-stepper) + (inner (void) on-tab-change old new)) + + (define/public (check-current-language-for-stepper) + (if (stepper-works-for? + (extract-language-level (get-definitions-text))) + (unless (send stepper-button is-shown?) + (send (send stepper-button get-parent) + add-child stepper-button)) + (when (send stepper-button is-shown?) + (send (send stepper-button get-parent) + delete-child stepper-button)))) + + ;; add the stepper button to the button panel: + (send (get-button-panel) change-children + (lx (cons stepper-button-parent-panel + (remq stepper-button-parent-panel _)))) + + ;; hide stepper button if it's not supported for the initial language: + (check-current-language-for-stepper))) + + ;; stepper-definitions-text-mixin : a mixin for the definitions text that + ;; alerts thet stepper when the definitions text is altered or destroyed + (define (stepper-definitions-text-mixin %) + (class % + + (inherit get-top-level-window) + (define/private (notify-stepper-frame-of-change) + (let ([win (get-top-level-window)]) + ;; should only be #f when win is #f + (when (is-a? win stepper-unit-frame<%>) + (let ([stepper-window (send win get-stepper-frame)]) + (when stepper-window + (send stepper-window original-program-changed)))))) + + (define/augment (on-insert x y) + (unless metadata-changing-now? + (notify-stepper-frame-of-change)) + (inner (void) on-insert x y)) + + (define/augment (on-delete x y) + (unless metadata-changing-now? + (notify-stepper-frame-of-change)) + (inner (void) on-delete x y)) + + (define/augment (after-set-next-settings s) + (let ([tlw (get-top-level-window)]) + (when tlw + (send tlw check-current-language-for-stepper))) + (inner (void) after-set-next-settings s)) + + (define metadata-changing-now? #f) + + ;; don't pay attention to changes that occur on metadata. + ;; this assumes that metadata changes cannot be nested. + (define/augment (begin-metadata-changes) + (set! metadata-changing-now? #t) + (inner (void) begin-metadata-changes)) + + (define/augment (end-metadata-changes) + (set! metadata-changing-now? #f) + (inner (void) end-metadata-changes)) + + (super-new))) + + ;; apply the mixins dynamically to the drscheme unit frame and + ;; definitions text: + (drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin) + (drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin) + + ;; COPIED FROM drscheme/private/language.ss +;; simple-module-based-language-convert-value : TST STYLE boolean -> TST +(define (simple-module-based-language-convert-value value style show-sharing?) + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (or (is-a? expr snip%) + ;; FIXME: internal in language.ss (to-snip-value? expr) + ) + expr + (sh expr basic-convert sub-convert))) + ;; mflatt: MINOR HACK - work around temporary + ;; print-convert problems + (define (stepper-print-convert v) + (or (and (procedure? v) (object-name v)) + (print-convert v))) + + (case style + [(write) value] + [(current-print) value] + [(constructor) + (parameterize + ([constructor-style-printing #t] + [show-sharing show-sharing?] + [current-print-convert-hook + (leave-snips-alone-hook (current-print-convert-hook))]) + (stepper-print-convert value))] + [(quasiquote) + (parameterize + ([constructor-style-printing #f] + [show-sharing show-sharing?] + [current-print-convert-hook + (leave-snips-alone-hook (current-print-convert-hook))]) + (stepper-print-convert value))] + [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) + +;; set-print-settings ; settings ( -> TST) -> TST +(define (set-print-settings language simple-settings thunk) + (if (method-in-interface? 'set-printing-parameters (object-interface language)) + (send language set-printing-parameters simple-settings thunk) + ;; assume that the current print-convert context is fine + ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") + (thunk))) + +;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC) + +;; stepper-convert-hook: +;; (TST (TST -> TST) (TST -> TST) -> TST) +;; this code copied from various locations in language.ss and rep.ss +(define (stepper-print-convert-hook exp basic-convert sub-convert) + (cond + [(is-a? exp snip%) + (send exp copy)] + #; + [((drscheme:rep:use-number-snip) exp) + (let ([number-snip-type + (drscheme:language:simple-settings-fraction-style + simple-settings)]) + (cond + [(eq? number-snip-type 'repeating-decimal) + (drscheme:number-snip:make-repeating-decimal-snip exp #f)] + [(eq? number-snip-type 'repeating-decimal-e) + (drscheme:number-snip:make-repeating-decimal-snip exp #t)] + [(eq? number-snip-type 'mixed-fraction) + (drscheme:number-snip:make-fraction-snip exp #f)] + [(eq? number-snip-type 'mixed-fraction-e) + (drscheme:number-snip:make-fraction-snip exp #t)] + [else + (error 'which-number-snip + "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e" + number-snip-type)]))] + [else (basic-convert exp)])) -)