From dae9aa6eeee00c56e083c8b8ee647d05ad8f346d Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 5 Feb 2008 21:56:49 +0000 Subject: [PATCH] changed macro-debugger to use v4 syntax (mostly) svn: r8544 original commit: 13a3c31ad5f63115427cfd34df285c0e981a8107 --- collects/macro-debugger/expand.ss | 49 +- collects/macro-debugger/model/context.ss | 257 ++-- collects/macro-debugger/model/debug.ss | 40 +- collects/macro-debugger/model/deriv-c.ss | 319 +++-- collects/macro-debugger/model/deriv-parser.ss | 1157 ++++++++--------- collects/macro-debugger/model/deriv-tokens.ss | 296 +++-- collects/macro-debugger/model/deriv-util.ss | 186 +-- collects/macro-debugger/model/deriv.ss | 714 +++++----- .../macro-debugger/model/hiding-policies.ss | 177 +-- .../macro-debugger/model/reductions-engine.ss | 825 ++++++------ collects/macro-debugger/model/reductions.ss | 1104 ++++++++-------- collects/macro-debugger/model/steps.ss | 185 ++- collects/macro-debugger/model/stx-util.ss | 185 ++- collects/macro-debugger/model/trace-raw.ss | 67 +- collects/macro-debugger/model/trace.ss | 128 +- collects/macro-debugger/model/yacc-ext.ss | 93 +- .../macro-debugger/model/yacc-interrupted.ss | 554 ++++---- collects/macro-debugger/stepper-text.ss | 269 ++-- collects/macro-debugger/stepper.ss | 13 +- collects/macro-debugger/syntax-browser.ss | 11 +- .../syntax-browser/controller.ss | 129 +- .../macro-debugger/syntax-browser/display.ss | 435 ++++--- .../macro-debugger/syntax-browser/embed.ss | 24 +- .../macro-debugger/syntax-browser/frame.ss | 170 ++- .../syntax-browser/hrule-snip.ss | 102 +- .../syntax-browser/interfaces.ss | 258 ++-- .../macro-debugger/syntax-browser/keymap.ss | 244 ++-- .../syntax-browser/partition.ss | 292 +++-- .../macro-debugger/syntax-browser/prefs.ss | 49 +- .../syntax-browser/pretty-helper.ss | 272 ++-- .../syntax-browser/pretty-printer.ss | 269 ++-- .../syntax-browser/properties.ss | 539 ++++---- .../macro-debugger/syntax-browser/text.ss | 545 ++++---- .../macro-debugger/syntax-browser/util.ss | 109 +- .../macro-debugger/syntax-browser/widget.ss | 441 ++++--- collects/macro-debugger/view/cursor.ss | 219 ++-- collects/macro-debugger/view/debug-format.ss | 100 +- collects/macro-debugger/view/debug.ss | 59 +- collects/macro-debugger/view/extensions.ss | 199 ++- collects/macro-debugger/view/frame.ss | 424 +++--- collects/macro-debugger/view/hiding-panel.ss | 565 ++++---- collects/macro-debugger/view/interfaces.ss | 82 +- collects/macro-debugger/view/prefs.ss | 186 ++- collects/macro-debugger/view/stepper.ss | 791 ++++++----- collects/macro-debugger/view/term-record.ss | 978 +++++++------- collects/macro-debugger/view/view.ss | 70 +- 46 files changed, 7062 insertions(+), 7118 deletions(-) diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss index 4cacf3e..ecb9f1e 100644 --- a/collects/macro-debugger/expand.ss +++ b/collects/macro-debugger/expand.ss @@ -1,27 +1,24 @@ +#lang scheme/base +(require "model/trace.ss" + "model/hide.ss") +(provide expand-only + expand/hide) -(module expand mzscheme - (require "model/trace.ss" - "model/hide.ss") - (provide expand-only - expand/hide) - - (define (expand-only stx show-list) - (define (show? id) - (ormap (lambda (x) (module-identifier=? id x)) - show-list)) - (expand/hiding stx show?)) - - (define (expand/hide stx hide-list) - (define (show? id) - (andmap (lambda (x) (not (module-identifier=? id x))) - hide-list)) - (expand/hiding stx show?)) - - (define (expand/hiding stx show?) - (let-values ([(result deriv) (trace/result stx)]) - (when (exn? result) - (raise result)) - (let-values ([(_d estx) (hide/policy deriv show?)]) - estx))) - - ) +(define (expand-only stx show-list) + (define (show? id) + (ormap (lambda (x) (free-identifier=? id x)) + show-list)) + (expand/hiding stx show?)) + +(define (expand/hide stx hide-list) + (define (show? id) + (andmap (lambda (x) (not (free-identifier=? id x))) + hide-list)) + (expand/hiding stx show?)) + +(define (expand/hiding stx show?) + (let-values ([(result deriv) (trace/result stx)]) + (when (exn? result) + (raise result)) + (let-values ([(_d estx) (hide/policy deriv show?)]) + estx))) diff --git a/collects/macro-debugger/model/context.ss b/collects/macro-debugger/model/context.ss index 9ddf18a..7ed83c0 100644 --- a/collects/macro-debugger/model/context.ss +++ b/collects/macro-debugger/model/context.ss @@ -1,142 +1,141 @@ +#lang scheme/base -(module context mzscheme - (require (lib "stx.ss" "syntax")) - (provide (struct ref (n)) - (struct tail (n)) - path-get - pathseg-get - path-replace - pathseg-replace - find-subterm-paths) - - ;; A Path is a (list-of PathSeg) - ;; where the PathSegs are listed outermost to innermost - ;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c - - ;; A PathSeg is one of: - ;; - (make-ref number) - ;; - (make-tail number) - - (define-struct pathseg () #f) - (define-struct (ref pathseg) (n) #f) - (define-struct (tail pathseg) (n) #f) +(require syntax/stx) +(provide (struct-out ref) + (struct-out tail) + path-get + pathseg-get + path-replace + pathseg-replace + find-subterm-paths) - ;; path:ref->splicing-tail : PathSeg -> ??? - ;; ???? - (define (path:ref->splicing-tail path) - (unless (ref? path) - (raise-type-error 'path:ref->splicing-tail "ref path" path)) - (make-tail (sub1 (ref-n path)))) +;; A Path is a (list-of PathSeg) +;; where the PathSegs are listed outermost to innermost +;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c - ;; path-get : syntax Path -> syntax - (define (path-get stx path) - (let loop ([stx stx] [path path]) - (cond [(null? path) stx] - [(pair? path) - (loop (pathseg-get stx (car path)) (cdr path))] - [else - (error 'path-get "bad path: ~s" path)]))) +;; A PathSeg is one of: +;; - (make-ref number) +;; - (make-tail number) - ;; pathseg-get : syntax PathSeg -> syntax - (define (pathseg-get stx path) - (cond [(ref? path) (pathseg-get/ref stx (ref-n path))] - [(tail? path) (pathseg-get/tail stx (tail-n path))])) - - ;; pathseg-get/ref : syntax number -> syntax - (define (pathseg-get/ref stx0 n0) - (let loop ([n n0] [stx stx0]) - (unless (stx-pair? stx) - (error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s" - n0 - (syntax-object->datum stx0))) - (if (zero? n) - (stx-car stx) - (loop (sub1 n) (stx-cdr stx))))) +(define-struct pathseg () #:transparent) +(define-struct (ref pathseg) (n) #:transparent) +(define-struct (tail pathseg) (n) #:transparent) - ;; pathseg-get/tail : syntax number -> syntax - (define (pathseg-get/tail stx0 n0) - (let loop ([n n0] [stx stx0]) - (unless (stx-pair? stx) - (error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) - (if (zero? n) - (stx-cdr stx) - (loop (sub1 n) (stx-cdr stx))))) +;; path:ref->splicing-tail : PathSeg -> ??? +;; ???? +(define (path:ref->splicing-tail path) + (unless (ref? path) + (raise-type-error 'path:ref->splicing-tail "ref path" path)) + (make-tail (sub1 (ref-n path)))) - ;; path-replace : syntax Path syntax -> syntax - (define (path-replace stx path x) - (cond [(null? path) x] +;; path-get : syntax Path -> syntax +(define (path-get stx path) + (let loop ([stx stx] [path path]) + (cond [(null? path) stx] [(pair? path) - (let ([pathseg0 (car path)]) - (pathseg-replace stx - pathseg0 - (path-replace (pathseg-get stx pathseg0) - (cdr path) - x)))] + (loop (pathseg-get stx (car path)) (cdr path))] [else - (error 'path-replace "bad path: ~s" path)])) + (error 'path-get "bad path: ~s" path)]))) - ;; pathseg-replace : syntax PathSeg syntax -> syntax - (define (pathseg-replace stx pathseg x) - (cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)] - [(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)] - [else (error 'pathseg-replace "bad path: ~s" pathseg)])) +;; pathseg-get : syntax PathSeg -> syntax +(define (pathseg-get stx path) + (cond [(ref? path) (pathseg-get/ref stx (ref-n path))] + [(tail? path) (pathseg-get/tail stx (tail-n path))])) - ;; pathseg-replace/ref : syntax number syntax -> syntax - (define (pathseg-replace/ref stx0 n0 x) - (let loop ([n n0] [stx stx0]) - (unless (stx-pair? stx) - (error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0)) - (if (zero? n) - (stx-replcar stx x) - (stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) +;; pathseg-get/ref : syntax number -> syntax +(define (pathseg-get/ref stx0 n0) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s" + n0 + (syntax->datum stx0))) + (if (zero? n) + (stx-car stx) + (loop (sub1 n) (stx-cdr stx))))) - ;; pathseg-replace/tail : syntax number syntax -> syntax - (define (pathseg-replace/tail stx0 n0 x) - (let loop ([n n0] [stx stx0]) - (unless (stx-pair? stx) - (error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) - (if (zero? n) - (stx-replcdr stx x) - (stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) +;; pathseg-get/tail : syntax number -> syntax +(define (pathseg-get/tail stx0 n0) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) + (if (zero? n) + (stx-cdr stx) + (loop (sub1 n) (stx-cdr stx))))) - ;; stx-replcar : syntax syntax -> syntax - (define (stx-replcar stx x) - (cond [(pair? stx) - (cons x (cdr stx))] - [(syntax? stx) - (datum->syntax-object stx (cons x (cdr (syntax-e stx))) stx stx)] - [else (raise-type-error 'stx-replcar "stx-pair" stx)])) +;; path-replace : syntax Path syntax -> syntax +(define (path-replace stx path x) + (cond [(null? path) x] + [(pair? path) + (let ([pathseg0 (car path)]) + (pathseg-replace stx + pathseg0 + (path-replace (pathseg-get stx pathseg0) + (cdr path) + x)))] + [else + (error 'path-replace "bad path: ~s" path)])) - ;; stx-replcdr : syntax syntax -> syntax - (define (stx-replcdr stx x) - (cond [(pair? stx) - (cons (car stx) x)] - [(and (syntax? stx) (pair? (syntax-e stx))) - (datum->syntax-object stx (cons (car (syntax-e stx)) x) stx stx)] - [else (raise-type-error 'stx-replcdr "stx-pair" stx)])) - - (define (sd x) - (syntax-object->datum (datum->syntax-object #f x))) - - ;;======= - - ;; find-subterm-paths : syntax syntax -> (list-of Path) - (define (find-subterm-paths subterm term) - (let outer-loop ([term term]) - (cond [(eq? subterm term) - (list null)] - [(stx-pair? term) - ;; Optimized for lists... - (let loop ([term term] [n 0]) - (if (stx-pair? term) - (let* ([seg0 (make-ref n)]) - (append (map (lambda (p) (cons seg0 p)) (outer-loop (stx-car term))) - (if (eq? subterm (stx-cdr term)) - (list (list (make-tail n))) - (loop (stx-cdr term) (add1 n))))) - (let ([seg0 (make-tail n)]) - (map (lambda (p) (cons seg0 p)) - (outer-loop term)))))] - ;; FIXME: more structured cases here: box, vector, ... - [else null]))) - ) +;; pathseg-replace : syntax PathSeg syntax -> syntax +(define (pathseg-replace stx pathseg x) + (cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)] + [(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)] + [else (error 'pathseg-replace "bad path: ~s" pathseg)])) + +;; pathseg-replace/ref : syntax number syntax -> syntax +(define (pathseg-replace/ref stx0 n0 x) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0)) + (if (zero? n) + (stx-replcar stx x) + (stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) + +;; pathseg-replace/tail : syntax number syntax -> syntax +(define (pathseg-replace/tail stx0 n0 x) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) + (if (zero? n) + (stx-replcdr stx x) + (stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) + +;; stx-replcar : syntax syntax -> syntax +(define (stx-replcar stx x) + (cond [(pair? stx) + (cons x (cdr stx))] + [(syntax? stx) + (datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)] + [else (raise-type-error 'stx-replcar "stx-pair" stx)])) + +;; stx-replcdr : syntax syntax -> syntax +(define (stx-replcdr stx x) + (cond [(pair? stx) + (cons (car stx) x)] + [(and (syntax? stx) (pair? (syntax-e stx))) + (datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)] + [else (raise-type-error 'stx-replcdr "stx-pair" stx)])) + +(define (sd x) + (syntax->datum (datum->syntax #f x))) + +;;======= + +;; find-subterm-paths : syntax syntax -> (list-of Path) +(define (find-subterm-paths subterm term) + (let outer-loop ([term term]) + (cond [(eq? subterm term) + (list null)] + [(stx-pair? term) + ;; Optimized for lists... + (let loop ([term term] [n 0]) + (if (stx-pair? term) + (let* ([seg0 (make-ref n)]) + (append (map (lambda (p) (cons seg0 p)) (outer-loop (stx-car term))) + (if (eq? subterm (stx-cdr term)) + (list (list (make-tail n))) + (loop (stx-cdr term) (add1 n))))) + (let ([seg0 (make-tail n)]) + (map (lambda (p) (cons seg0 p)) + (outer-loop term)))))] + ;; FIXME: more structured cases here: box, vector, ... + [else null]))) diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index b39030f..d345a20 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -1,22 +1,22 @@ -(module debug mzscheme - (require (lib "plt-match.ss")) - (require "trace.ss" - "reductions.ss" - "deriv-util.ss" - "deriv-find.ss" - "hide.ss" - "hiding-policies.ss" - "deriv.ss" - "steps.ss") +#lang scheme/base - (provide (all-from "trace.ss") - (all-from "reductions.ss") - (all-from "deriv.ss") - (all-from "deriv-util.ss") - (all-from "deriv-find.ss") - (all-from "hiding-policies.ss") - (all-from "hide.ss") - (all-from "steps.ss") - (all-from (lib "plt-match.ss"))) - ) +(require scheme/match + "trace.ss" + "reductions.ss" + "deriv-util.ss" + "deriv-find.ss" + "hide.ss" + "hiding-policies.ss" + "deriv.ss" + "steps.ss") + +(provide (all-from-out "trace.ss") + (all-from-out "reductions.ss") + (all-from-out "deriv.ss") + (all-from-out "deriv-util.ss") + (all-from-out "deriv-find.ss") + (all-from-out "hiding-policies.ss") + (all-from-out "hide.ss") + (all-from-out "steps.ss") + (all-from-out scheme/match)) diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index be85e5d..7a7d597 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -1,187 +1,184 @@ -(module deriv-c mzscheme - (provide (all-defined)) +#lang scheme/base +(provide (all-defined-out)) - ;; A Node(a) is: - ;; (make-node a ?a) - (define-struct node (z1 z2) #f) - - ;; A TopDeriv is one of - ;; (make-lift-deriv Deriv Stxs TopDeriv) - ;; Deriv - - ;; A Deriv is one of - ;; (make-mrule Transformation Deriv) - ;; PrimDeriv - (define-struct (deriv node) () #f) - (define-struct (lift-deriv deriv) (first lift-stx second) #f) - (define-struct (mrule deriv) (transformation next) #f) +;; A Node(a) is: +;; (make-node a ?a) +(define-struct node (z1 z2) #:transparent) - ;; A DerivLL is one of - ;; (make-lift/let-deriv Deriv Stx Deriv) - ;; Deriv - (define-struct (lift/let-deriv deriv) (first lift-stx second) #f) +;; A TopDeriv is one of +;; (make-lift-deriv Deriv Stxs TopDeriv) +;; Deriv - ;; A Transformation is - ;; (make-transformation Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number) - (define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #f) +;; A Deriv is one of +;; (make-mrule Transformation Deriv) +;; PrimDeriv +(define-struct (deriv node) () #:transparent) +(define-struct (lift-deriv deriv) (first lift-stx second) #:transparent) +(define-struct (mrule deriv) (transformation next) #:transparent) - ;; A LocalAction is one of - ;; (make-local-expansion Stx ?Stx Boolean Deriv) - ;; (make-local-expansion/expr Stx ?Stx Boolean ?Opaque Deriv) - ;; (make-local-lift Stx Identifier) - ;; (make-local-lift-end Stx) - ;; (make-local-bind BindSyntaxes) - (define-struct (local-expansion node) (me1 me2 for-stx? inner) #f) - (define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #f) - (define-struct local-lift (expr id) #f) - (define-struct local-lift-end (decl) #f) - (define-struct local-bind (bindrhs) #f) +;; A DerivLL is one of +;; (make-lift/let-deriv Deriv Stx Deriv) +;; Deriv +(define-struct (lift/let-deriv deriv) (first lift-stx second) #:transparent) - ;; Base = << Node(Stx) Rs ?exn >> - (define-struct (base deriv) (resolves ?1) #f) +;; A Transformation is +;; (make-transformation Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number) +(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #:transparent) - ;; A PrimDeriv is one of - (define-struct (prule base) () #f) - (define-struct (p:variable prule) () #f) +;; A LocalAction is one of +;; (make-local-expansion Stx ?Stx Boolean Deriv) +;; (make-local-expansion/expr Stx ?Stx Boolean ?Opaque Deriv) +;; (make-local-lift Stx Identifier) +;; (make-local-lift-end Stx) +;; (make-local-bind BindSyntaxes) +(define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent) +(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent) +(define-struct local-lift (expr id) #:transparent) +(define-struct local-lift-end (decl) #:transparent) +(define-struct local-bind (bindrhs) #:transparent) - ;; (make-p:module Boolean ?Deriv ?exn Deriv) - ;; (make-p:#%module-begin ModulePass1 ModulePass2 ?exn) - (define-struct (p:module prule) (one-body-form? mb ?2 body) #f) - (define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #f) +;; Base = << Node(Stx) Rs ?exn >> +(define-struct (base deriv) (resolves ?1) #:transparent) - ;; (make-p:define-syntaxes DerivLL) - ;; (make-p:define-values Deriv) - (define-struct (p:define-syntaxes prule) (rhs ?2) #f) - (define-struct (p:define-values prule) (rhs) #f) +;; A PrimDeriv is one of +(define-struct (prule base) () #:transparent) +(define-struct (p:variable prule) () #:transparent) - ;; (make-p:#%expression Deriv) - ;; (make-p:if Boolean Deriv Deriv Deriv) - ;; (make-p:wcm Deriv Deriv Deriv) - ;; (make-p:set! Rs Deriv) - ;; (make-p:set!-macro Rs Deriv) - (define-struct (p:#%expression prule) (inner) #f) - (define-struct (p:if prule) (full? test then else) #f) - (define-struct (p:wcm prule) (key mark body) #f) - (define-struct (p:set! prule) (id-resolves rhs) #f) - (define-struct (p:set!-macro prule) (deriv) #f) +;; (make-p:module Boolean ?Deriv ?exn Deriv) +;; (make-p:#%module-begin ModulePass1 ModulePass2 ?exn) +(define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent) +(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent) - ;; (make-p:#%app Stx LDeriv) - ;; (make-p:begin LDeriv) - ;; (make-p:begin0 Deriv LDeriv) - (define-struct (p:#%app prule) (tagged-stx lderiv) #f) - (define-struct (p:begin prule) (lderiv) #f) - (define-struct (p:begin0 prule) (first lderiv) #f) +;; (make-p:define-syntaxes DerivLL) +;; (make-p:define-values Deriv) +(define-struct (p:define-syntaxes prule) (rhs ?2) #:transparent) +(define-struct (p:define-values prule) (rhs) #:transparent) - ;; (make-p:lambda LambdaRenames BDeriv) - ;; (make-p:case-lambda (list-of CaseLambdaClause)) - ;; (make-p:let-values LetRenames (list-of Deriv) BDeriv) - ;; (make-p:letrec-values LetRenames (list-of Deriv) BDeriv) - ;; (make-p:letrec-syntaxes+values LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv) - (define-struct (p:lambda prule) (renames body) #f) - (define-struct (p:case-lambda prule) (renames+bodies) #f) - (define-struct (p:let-values prule) (renames rhss body) #f) - (define-struct (p:letrec-values prule) (renames rhss body) #f) - (define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #f) +;; (make-p:#%expression Deriv) +;; (make-p:if Boolean Deriv Deriv Deriv) +;; (make-p:wcm Deriv Deriv Deriv) +;; (make-p:set! Rs Deriv) +;; (make-p:set!-macro Rs Deriv) +(define-struct (p:#%expression prule) (inner) #:transparent) +(define-struct (p:if prule) (full? test then else) #:transparent) +(define-struct (p:wcm prule) (key mark body) #:transparent) +(define-struct (p:set! prule) (id-resolves rhs) #:transparent) +(define-struct (p:set!-macro prule) (deriv) #:transparent) - ;; (make-p:stop ) - ;; (make-p:unknown ) - ;; (make-p:#%top Stx) - ;; (make-p:#%datum Stx) - ;; (make-p:quote ) - ;; (make-p:quote-syntax ) - ;; (make-p:require ) - ;; (make-p:require-for-syntax ) - ;; (make-p:require-for-template ) - ;; (make-p:provide ) - (define-struct (p::STOP prule) () #f) - (define-struct (p:stop p::STOP) () #f) - (define-struct (p:unknown p::STOP) () #f) - (define-struct (p:#%top p::STOP) (tagged-stx) #f) - (define-struct (p:#%datum p::STOP) (tagged-stx) #f) - (define-struct (p:quote p::STOP) () #f) - (define-struct (p:quote-syntax p::STOP) () #f) - (define-struct (p:require p::STOP) () #f) - (define-struct (p:require-for-syntax p::STOP) () #f) - (define-struct (p:require-for-template p::STOP) () #f) - (define-struct (p:provide p::STOP) () #f) +;; (make-p:#%app Stx LDeriv) +;; (make-p:begin LDeriv) +;; (make-p:begin0 Deriv LDeriv) +(define-struct (p:#%app prule) (tagged-stx lderiv) #:transparent) +(define-struct (p:begin prule) (lderiv) #:transparent) +(define-struct (p:begin0 prule) (first lderiv) #:transparent) - ;;+ (make-p:rename Renames Deriv) - ;;+ (make-p:synth (list-of SynthItem) ?exn) - (define-struct (p:rename prule) (renames inner) #f) - (define-struct (p:synth prule) (subterms ?2) #f) +;; (make-p:lambda LambdaRenames BDeriv) +;; (make-p:case-lambda (list-of CaseLambdaClause)) +;; (make-p:let-values LetRenames (list-of Deriv) BDeriv) +;; (make-p:letrec-values LetRenames (list-of Deriv) BDeriv) +;; (make-p:letrec-syntaxes+values LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv) +(define-struct (p:lambda prule) (renames body) #:transparent) +(define-struct (p:case-lambda prule) (renames+bodies) #:transparent) +(define-struct (p:let-values prule) (renames rhss body) #:transparent) +(define-struct (p:letrec-values prule) (renames rhss body) #:transparent) +(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #:transparent) + +;; (make-p:stop ) +;; (make-p:unknown ) +;; (make-p:#%top Stx) +;; (make-p:#%datum Stx) +;; (make-p:quote ) +;; (make-p:quote-syntax ) +;; (make-p:require ) +;; (make-p:require-for-syntax ) +;; (make-p:require-for-template ) +;; (make-p:provide ) +(define-struct (p::STOP prule) () #:transparent) +(define-struct (p:stop p::STOP) () #:transparent) +(define-struct (p:unknown p::STOP) () #:transparent) +(define-struct (p:#%top p::STOP) (tagged-stx) #:transparent) +(define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent) +(define-struct (p:quote p::STOP) () #:transparent) +(define-struct (p:quote-syntax p::STOP) () #:transparent) +(define-struct (p:require p::STOP) () #:transparent) +(define-struct (p:require-for-syntax p::STOP) () #:transparent) +(define-struct (p:require-for-template p::STOP) () #:transparent) +(define-struct (p:provide p::STOP) () #:transparent) + +;;+ (make-p:rename Renames Deriv) +;;+ (make-p:synth (list-of SynthItem) ?exn) +(define-struct (p:rename prule) (renames inner) #:transparent) +(define-struct (p:synth prule) (subterms ?2) #:transparent) - - ;; A LDeriv is - ;; (make-lderiv ?exn (list-of Deriv)) - (define-struct (lderiv node) (?1 derivs) #f) - ;; A BDeriv is - ;; (make-bderiv (list-of BRule) (U 'list 'letrec) LDeriv) - (define-struct (bderiv node) (pass1 trans pass2) #f) +;; A LDeriv is +;; (make-lderiv ?exn (list-of Deriv)) +(define-struct (lderiv node) (?1 derivs) #:transparent) - ;; A BRule is one of - ;; (make-b:error exn) - ;; (make-b:expr BlockRenames Deriv) - ;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn) - ;; (make-b:defvals BlockRenames Deriv ?exn) - ;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes) - ;;i (make-b:begin BlockRenames Deriv (list-of Deriv)) - (define-struct b:error (?1) #f) - (define-struct brule (renames) #f) - (define-struct (b:expr brule) (head) #f) - (define-struct (b:splice brule) (head ?1 tail ?2) #f) - (define-struct (b:defvals brule) (head ?1) #f) - (define-struct (b:defstx brule) (head ?1 bindrhs) #f) -;;(define-struct (b:begin brule) (head inner) #f) +;; A BDeriv is +;; (make-bderiv (list-of BRule) (U 'list 'letrec) LDeriv) +(define-struct (bderiv node) (pass1 trans pass2) #:transparent) - ;; A BindSyntaxes is - ;; (make-bind-syntaxes DerivLL ?exn) - (define-struct bind-syntaxes (rhs ?1) #f) +;; A BRule is one of +;; (make-b:error exn) +;; (make-b:expr BlockRenames Deriv) +;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn) +;; (make-b:defvals BlockRenames Deriv ?exn) +;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes) +;;i (make-b:begin BlockRenames Deriv (list-of Deriv)) +(define-struct b:error (?1) #:transparent) +(define-struct brule (renames) #:transparent) +(define-struct (b:expr brule) (head) #:transparent) +(define-struct (b:splice brule) (head ?1 tail ?2) #:transparent) +(define-struct (b:defvals brule) (head ?1) #:transparent) +(define-struct (b:defstx brule) (head ?1 bindrhs) #:transparent) +;;(define-struct (b:begin brule) (head inner) #:transparent) + +;; A BindSyntaxes is +;; (make-bind-syntaxes DerivLL ?exn) +(define-struct bind-syntaxes (rhs ?1) #:transparent) - ;; A CaseLambdaClause is - ;; (make-clc ?exn CaseLambdaRename BDeriv) - (define-struct clc (?1 renames body) #f) +;; A CaseLambdaClause is +;; (make-clc ?exn CaseLambdaRename BDeriv) +(define-struct clc (?1 renames body) #:transparent) - ;; A BlockRename is (cons Stx Stx) +;; A BlockRename is (cons Stx Stx) - ;; A ModPass1 is (list-of ModRule1) - ;; A ModPass2 is (list-of ModRule2) +;; A ModPass1 is (list-of ModRule1) +;; A ModPass2 is (list-of ModRule2) - ;; A ModRule1 is one of - ;; (make-mod:prim Deriv ModPrim) - ;; (make-mod:splice Deriv ?exn Stxs) - ;; (make-mod:lift Deriv Stxs) - ;; (make-mod:lift-end Stxs) - ;; A ModRule2 is one of - ;; (make-mod:skip) - ;; (make-mod:cons Deriv) - ;; (make-mod:lift Deriv Stxs) - (define-struct modrule () #f) - (define-struct (mod:cons modrule) (head) #f) - (define-struct (mod:prim modrule) (head prim) #f) - (define-struct (mod:skip modrule) () #f) - (define-struct (mod:splice modrule) (head ?1 tail) #f) - (define-struct (mod:lift modrule) (head tail) #f) - (define-struct (mod:lift-end modrule) (tail) #f) +;; A ModRule1 is one of +;; (make-mod:prim Deriv ModPrim) +;; (make-mod:splice Deriv ?exn Stxs) +;; (make-mod:lift Deriv Stxs) +;; (make-mod:lift-end Stxs) +;; A ModRule2 is one of +;; (make-mod:skip) +;; (make-mod:cons Deriv) +;; (make-mod:lift Deriv Stxs) +(define-struct modrule () #:transparent) +(define-struct (mod:cons modrule) (head) #:transparent) +(define-struct (mod:prim modrule) (head prim) #:transparent) +(define-struct (mod:skip modrule) () #:transparent) +(define-struct (mod:splice modrule) (head ?1 tail) #:transparent) +(define-struct (mod:lift modrule) (head tail) #:transparent) +(define-struct (mod:lift-end modrule) (tail) #:transparent) - ;; A ModPrim is a PRule in: - ;; (make-p:define-values #f) - ;; (make-p:define-syntaxes Deriv) - ;; (make-p:require ) - ;; (make-p:require-for-syntax ) - ;; (make-p:require-for-template ) - ;; (make-p:provide ) - ;; #f +;; A ModPrim is a PRule in: +;; (make-p:define-values #:transparent) +;; (make-p:define-syntaxes Deriv) +;; (make-p:require ) +;; (make-p:require-for-syntax ) +;; (make-p:require-for-template ) +;; (make-p:provide ) +;; #f - ;; A SynthItem is one of - ;; - (make-s:subterm Path Deriv) - ;; - (make-s:rename Path Stx Stx) - (define-struct subitem () #f) - (define-struct (s:subterm subitem) (path deriv) #f) - (define-struct (s:rename subitem) (path before after) #f) - - - ) +;; A SynthItem is one of +;; - (make-s:subterm Path Deriv) +;; - (make-s:rename Path Stx Stx) +(define-struct subitem () #:transparent) +(define-struct (s:subterm subitem) (path deriv) #:transparent) +(define-struct (s:rename subitem) (path before after) #:transparent) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index e60992f..277d9fd 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -1,580 +1,579 @@ -(module deriv-parser mzscheme - (require "yacc-ext.ss" - "yacc-interrupted.ss" - "deriv.ss" - "deriv-util.ss" - "deriv-tokens.ss") - (provide parse-derivation) - - (define (deriv-error ok? name value start end) - (if ok? - (error 'derivation-parser - "error on token #~a: <~s, ~s>" - start name value) - (error 'derivation-parser "bad token #~a" start))) - - ;; PARSER - - (define (parse-derivation x) - (parameterize ((current-sequence-number 0)) - (parse-derivation* x))) - - (define current-sequence-number (make-parameter #f)) - (define (new-sequence-number) - (let ([seq (current-sequence-number)]) - (current-sequence-number (add1 seq)) - seq)) - - (define-struct (exn:eval exn) (deriv)) - (define empty-cms - (call-with-continuation-prompt (lambda () (current-continuation-marks)))) - (define (create-eval-exn deriv) - (make-exn:eval "exception during evaluation" - empty-cms - deriv)) - - (define-production-splitter production/I values values) - - (define-syntax (productions/I stx) - (syntax-case stx () - [(productions/I def ...) - #'(begin (production/I def) ...)])) - - (define parse-derivation* - (parser - (options (start Expansion) - (src-pos) - (tokens basic-tokens prim-tokens renames-tokens) - (end EOF) - (error deriv-error) - #;(debug "DEBUG-PARSER.txt")) - - ;; tokens - (skipped-token-values - visit resolve next next-group return - enter-macro macro-pre-transform macro-post-transform exit-macro - enter-prim exit-prim - enter-block block->list block->letrec splice - enter-list exit-list - enter-check exit-check - local-post exit-local exit-local/expr - phase-up module-body - renames-lambda - renames-case-lambda - renames-let - renames-letrec-syntaxes - renames-block - IMPOSSIBLE) - - ;; Entry point - (productions - (Expansion - [(start EE/Lifts) $2] - [(start EE/Lifts/Interrupted) $2])) - - (productions/I - - ;; Expand/Lifts - (EE/Lifts - (#:no-wrap) - [((? EE)) $1] - [((? EE/Lifts+)) $1]) - - (EE/Lifts+ - (#:no-wrap) - [(EE lift-loop (? EE/Lifts)) - (let ([e1 (wderiv-e1 $1)] - [e2 (wderiv-e2 $3)]) - (make lift-deriv e1 e2 $1 $2 $3))]) - - ;; Expansion of an expression - ;; EE Answer = Derivation (I) - (EE - (#:no-wrap) - [(visit (? PrimStep) return) - ($2 $1 $3)] - [((? EE/Macro)) - $1]) - - (EE/Macro - (#:wrap) - [(visit (? MacroStep) (? EE)) - (make mrule $1 (and $3 (wderiv-e2 $3)) $2 $3)]) - - ;; Expand/LetLifts - ;; Used for expand_lift_to_let (rhs of define-syntaxes, mostly) - (EE/LetLifts - (#:no-wrap) - [((? EE)) $1] - [((? EE/LetLifts+)) $1]) - - (EE/LetLifts+ - (#:wrap) - [(EE lift/let-loop (? EE/LetLifts)) - (let ([initial (wderiv-e1 $1)] - [final (wderiv-e2 $3)]) - (make lift/let-deriv initial final $1 $2 $3))]) - - ;; Evaluation - ;; Answer = ?exn - (Eval - (#:no-wrap) - [() #f] - [(!!) $1] - [(start EE/Interrupted) (create-eval-exn $2)] - [(start EE (? Eval)) $3] - [(start CheckImmediateMacro/Interrupted) (create-eval-exn $2)] - [(start CheckImmediateMacro (? Eval)) $3]) - - ;; Expansion of an expression to primitive form - (CheckImmediateMacro - (#:no-wrap) - [(enter-check (? CheckImmediateMacro/Inner) exit-check) - ($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))]) - (CheckImmediateMacro/Inner - (#:args e1 e2 k) - (#:wrap) - [() - (k e1 e2)] - [(visit (? MacroStep) return (? CheckImmediateMacro/Inner)) - (let ([next ($4 $3 e2 k)]) - (make mrule $1 (and next (wderiv-e2 next)) $2 next))]) - - ;; Expansion of multiple expressions, next-separated - (NextEEs - (#:no-wrap) - (#:skipped null) - [() null] - [(next (? EE) (? NextEEs)) (cons $2 $3)]) - - ;; Keyword resolution - (Resolves - (#:no-wrap) - [() null] - [(resolve Resolves) (cons $1 $2)]) - - ;; Single macro step (may contain local-expand calls) - ;; MacroStep Answer = Transformation (I,E) - (MacroStep - (#:wrap) - [(Resolves enter-macro ! macro-pre-transform (? LocalActions) - ! macro-post-transform exit-macro) - (make transformation $2 $8 $1 $3 $4 $5 $6 $7 (new-sequence-number))]) - - ;; Local actions taken by macro - ;; LocalAction Answer = (list-of LocalAction) - (LocalActions - (#:no-wrap) - (#:skipped null) - [() null] - [((? LocalAction) (? LocalActions)) (cons $1 $2)] - [((? NotReallyLocalAction) (? LocalActions)) $2]) - - (LocalAction - (#:no-wrap) - [(enter-local local-pre start (? EE) local-post exit-local) - (make local-expansion $1 $6 $2 $5 #f $4)] - [(enter-local phase-up local-pre start (? EE) local-post exit-local) - (make local-expansion $1 $7 $3 $6 #t $5)] - [(enter-local/expr local-pre start (? EE) local-post exit-local/expr) - (make local-expansion/expr $1 (car $6) $2 $5 #f (cdr $6) $4)] - [(enter-local/expr local-pre phase-up start (? EE) local-post exit-local/expr) - (make local-expansion/expr $1 (car $7) $3 $6 #t (cdr $7) $5)] - [(lift) - (make local-lift (cdr $1) (car $1))] - [(lift-statement) - (make local-lift-end $1)] - [((? BindSyntaxes)) - (make local-bind $1)]) - - (NotReallyLocalAction - (#:no-wrap) - ;; called 'expand' (not 'local-expand') within transformer - [(start (? EE)) - (make local-expansion (wderiv-e1 $2) - (wderiv-e2 $2) - (wderiv-e1 $2) - (wderiv-e2 $2) - #f - $2)]) - - ;; Primitive - (PrimStep - (#:args e1 e2) - (#:no-wrap) - [(Resolves (? PrimError)) - ($2 e1 e2 $1)] - [(Resolves Variable) - ($2 e1 e2 $1)] - [(Resolves enter-prim (? Prim) exit-prim) - ($3 e1 e2 $1)] - [(Resolves enter-prim (? TaggedPrim) exit-prim) - ($3 e1 $4 $1 $2)]) - - (PrimError - (#:args e1 e2 rs) - (#:wrap) - [(! IMPOSSIBLE) - (make p:unknown e1 e2 rs $1)]) - - (Variable - (#:args e1 e2 rs) - (#:wrap) - [(variable) - (make p:variable e1 e2 rs #f)]) - - (TaggedPrim - (#:args e1 e2 rs tagged-stx) - (#:no-wrap) - [((? Prim#%App)) ($1 e1 e2 rs tagged-stx)] - [((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)] - [((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)]) - - (Prim - (#:args e1 e2 rs) - (#:no-wrap) - [((? PrimModule)) ($1 e1 e2 rs)] - [((? Prim#%ModuleBegin)) ($1 e1 e2 rs)] - [((? PrimDefineSyntaxes)) ($1 e1 e2 rs)] - [((? PrimDefineValues)) ($1 e1 e2 rs)] - [((? PrimExpression)) ($1 e1 e2 rs)] - [((? PrimIf)) ($1 e1 e2 rs)] - [((? PrimWCM)) ($1 e1 e2 rs)] - [((? PrimSet)) ($1 e1 e2 rs)] - [((? PrimBegin)) ($1 e1 e2 rs)] - [((? PrimBegin0)) ($1 e1 e2 rs)] - [((? PrimLambda)) ($1 e1 e2 rs)] - [((? PrimCaseLambda)) ($1 e1 e2 rs)] - [((? PrimLetValues)) ($1 e1 e2 rs)] - [((? PrimLet*Values)) ($1 e1 e2 rs)] - [((? PrimLetrecValues)) ($1 e1 e2 rs)] - [((? PrimLetrecSyntaxes+Values)) ($1 e1 e2 rs)] - [((? PrimSTOP)) ($1 e1 e2 rs)] - [((? PrimQuote)) ($1 e1 e2 rs)] - [((? PrimQuoteSyntax)) ($1 e1 e2 rs)] - [((? PrimRequire)) ($1 e1 e2 rs)] - [((? PrimRequireForSyntax)) ($1 e1 e2 rs)] - [((? PrimRequireForTemplate)) ($1 e1 e2 rs)] - [((? PrimProvide)) ($1 e1 e2 rs)]) - - (PrimModule - (#:args e1 e2 rs) - (#:wrap) - ;; Multiple forms after language: tagging done automatically - [(prim-module (? Eval) (? EE)) - (make p:module e1 e2 rs $2 #f #f #f $3)] - ;; One form after language: macro that expands into #%module-begin - [(prim-module Eval next (? CheckImmediateMacro) next ! (? EE)) - (make p:module e1 e2 rs #f #t $4 $6 $7)]) - - (Prim#%ModuleBegin - (#:args e1 e2 rs) - (#:wrap) - [(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !) - (make p:#%module-begin e1 e2 rs $2 $3 $5 $6)]) - - (ModulePass1 - (#:no-wrap) - (#:skipped null) - [() null] - [(next (? ModulePass1-Part) (? ModulePass1)) - (cons $2 $3)] - [(module-lift-end-loop (? ModulePass1)) - (cons (make mod:lift-end $1) $2)]) - - (ModulePass1-Part - (#:wrap) - [((? EE) (? ModulePass1/Prim)) - (make mod:prim $1 $2)] - [(EE ! splice) - (make mod:splice $1 $2 $3)] - [(EE module-lift-loop) - (make mod:lift $1 $2)]) - - (ModulePass1/Prim - (#:wrap) - [(enter-prim prim-define-values ! exit-prim) - (make p:define-values $1 $4 null $3 #f)] - [(enter-prim prim-define-syntaxes ! - phase-up (? EE/LetLifts) (? Eval) exit-prim) - (make p:define-syntaxes $1 $7 null $3 $5 $6)] - [(enter-prim prim-require (? Eval) exit-prim) - (make p:require $1 $4 null $3)] - [(enter-prim prim-require-for-syntax (? Eval) exit-prim) - (make p:require-for-syntax $1 $4 null $3)] - [(enter-prim prim-require-for-template (? Eval) exit-prim) - (make p:require-for-template $1 $4 null $3)] - [(enter-prim prim-provide ! exit-prim) - (make p:provide $1 $4 null $3)] - [() - #f]) - - (ModulePass2 - (#:no-wrap) - (#:skipped null) - [() null] - [(next (? ModulePass2-Part) (? ModulePass2)) - (cons $2 $3)] - [(module-lift-end-loop (? ModulePass2)) - (cons (make mod:lift-end $1) $2)]) - - (ModulePass2-Part - (#:no-wrap) - ;; not normal; already handled - [() - (make mod:skip)] - ;; normal: expand completely - [((? EE)) - (make mod:cons $1)] - ;; catch lifts - [(EE module-lift-loop) - (make mod:lift $1 $2)]) - - ;; Definitions - (PrimDefineSyntaxes - (#:args e1 e2 rs) - (#:wrap) - [(prim-define-syntaxes ! (? EE/LetLifts) (? Eval)) - (make p:define-syntaxes e1 e2 rs $2 $3 $4)]) - - (PrimDefineValues - (#:args e1 e2 rs) - (#:wrap) - [(prim-define-values ! (? EE)) - (make p:define-values e1 e2 rs $2 $3)]) - - ;; Simple expressions - (PrimExpression - (#:args e1 e2 rs) - (#:wrap) - [(prim-expression ! (? EE)) - (make p:#%expression e1 e2 rs $2 $3)]) - - (PrimIf - (#:args e1 e2 rs) - (#:wrap) - [(prim-if ! (? EE) next (? EE) next (? EE)) - (make p:if e1 e2 rs $2 #t $3 $5 $7)] - [(prim-if next-group (? EE) next (? EE)) - (make p:if e1 e2 rs #f #f $3 $5 #f)]) - - (PrimWCM - (#:args e1 e2 rs) - (#:wrap) - [(prim-wcm ! (? EE) next (? EE) next (? EE)) - (make p:wcm e1 e2 rs $2 $3 $5 $7)]) - - ;; Sequence-containing expressions - (PrimBegin - (#:args e1 e2 rs) - (#:wrap) - [(prim-begin ! (? EL)) - (make p:begin e1 e2 rs $2 $3)]) - - (PrimBegin0 - (#:args e1 e2 rs) - (#:wrap) - [(prim-begin0 ! next (? EE) next (? EL)) - (make p:begin0 e1 e2 rs $2 $4 $6)]) - - (Prim#%App - (#:args e1 e2 rs tagged-stx) - (#:wrap) - [(prim-#%app !) - (make p:#%app e1 e2 rs $2 tagged-stx (make lderiv null null #f null))] - [(prim-#%app (? EL)) - (make p:#%app e1 e2 rs #f tagged-stx $2)]) - - ;; Binding expressions - (PrimLambda - (#:args e1 e2 rs) - (#:wrap) - [(prim-lambda ! renames-lambda (? EB)) - (make p:lambda e1 e2 rs $2 $3 $4)]) - - (PrimCaseLambda - (#:args e1 e2 rs) - (#:wrap) - [(prim-case-lambda ! (? NextCaseLambdaClauses)) - (make p:case-lambda e1 e2 rs $2 $3)]) - - (NextCaseLambdaClauses - (#:skipped null) - (#:no-wrap) - [(next (? CaseLambdaClause) (? NextCaseLambdaClauses)) - (cons $2 $3)] - [() null]) - - (CaseLambdaClause - (#:wrap) - [(! renames-case-lambda (? EB)) - (make clc $1 $2 $3)]) - - (PrimLetValues - (#:args e1 e2 rs) - (#:wrap) - [(prim-let-values ! renames-let (? NextEEs) next-group (? EB)) - (make p:let-values e1 e2 rs $2 $3 $4 $6)]) - - (PrimLet*Values - (#:args e1 e2 rs) - (#:wrap) - ;; let*-values with bindings is "macro-like" - [(prim-let*-values !!) - (let ([tx (make transformation e1 #f rs $2 - #f null #f #f (new-sequence-number))]) - (make mrule e1 e2 tx #f))] - [(prim-let*-values (? EE)) - (let* ([next-e1 (wderiv-e1 $2)] - [tx (make transformation e1 next-e1 rs #f - e1 null #f next-e1 (new-sequence-number))]) - (make mrule e1 e2 tx $2))] - ;; No bindings... model as "let" - [(prim-let*-values renames-let (? NextEEs) next-group (? EB)) - (make p:let-values e1 e2 rs #f $2 $3 $5)]) - - (PrimLetrecValues - (#:args e1 e2 rs) - (#:wrap) - [(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB)) - (make p:letrec-values e1 e2 rs $2 $3 $4 $6)]) - - (PrimLetrecSyntaxes+Values - (#:args e1 e2 rs) - (#:wrap) - [(prim-letrec-syntaxes+values ! renames-letrec-syntaxes - (? NextBindSyntaxess) next-group (? EB)) - (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)] - [(prim-letrec-syntaxes+values renames-letrec-syntaxes - NextBindSyntaxess next-group - prim-letrec-values - renames-let (? NextEEs) next-group (? EB)) - (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9)]) - - ;; Atomic expressions - (Prim#%Datum - (#:args e1 e2 rs tagged-stx) - (#:wrap) - [(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)]) - - (Prim#%Top - (#:args e1 e2 rs tagged-stx) - (#:wrap) - [(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)]) - - (PrimSTOP - (#:args e1 e2 rs) - (#:wrap) - [(prim-stop !) (make p:stop e1 e2 rs $2)]) - - (PrimQuote - (#:args e1 e2 rs) - (#:wrap) - [(prim-quote !) (make p:quote e1 e2 rs $2)]) - - (PrimQuoteSyntax - (#:args e1 e2 rs) - (#:wrap) - [(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)]) - - (PrimRequire - (#:args e1 e2 rs) - (#:wrap) - [(prim-require (? Eval)) - (make p:require e1 e2 rs $2)]) - - (PrimRequireForSyntax - (#:args e1 e2 rs) - (#:wrap) - [(prim-require-for-syntax (? Eval)) - (make p:require-for-syntax e1 e2 rs $2)]) - - (PrimRequireForTemplate - (#:args e1 e2 rs) - (#:wrap) - [(prim-require-for-template (? Eval)) - (make p:require-for-template e1 e2 rs $2)]) - - (PrimProvide - (#:args e1 e2 rs) - (#:wrap) - [(prim-provide !) (make p:provide e1 e2 rs $2)]) - - (PrimSet - (#:args e1 e2 rs) - (#:wrap) - [(prim-set! ! Resolves next (? EE)) - (make p:set! e1 e2 rs $2 $3 $5)] - [(prim-set! (? MacroStep) (? EE)) - (make p:set!-macro e1 e2 rs #f - (make mrule e1 (and $3 (wderiv-e2 $3)) $2 $3))]) - - ;; Blocks - ;; EB Answer = BlockDerivation - (EB - (#:wrap) - [(enter-block (? BlockPass1) block->list (? EL)) - (make bderiv $1 (and $4 (wlderiv-es2 $4)) - $2 'list $4)] - [(enter-block BlockPass1 block->letrec (? EL)) - (make bderiv $1 (and $4 (wlderiv-es2 $4)) - $2 'letrec $4)]) - - ;; BlockPass1 Answer = (list-of BRule) - (BlockPass1 - (#:no-wrap) - (#:skipped null) - [() null] - [((? BRule) (? BlockPass1)) - (cons $1 $2)]) - - ;; BRule Answer = BRule - (BRule - (#:wrap) - [(next !!) - (make b:error $2)] - [(next renames-block (? CheckImmediateMacro)) - (make b:expr $2 $3)] - [(next renames-block CheckImmediateMacro prim-begin ! splice !) - (make b:splice $2 $3 $5 $6 $7)] - [(next renames-block CheckImmediateMacro prim-define-values !) - (make b:defvals $2 $3 $5)] - [(next renames-block CheckImmediateMacro - prim-define-syntaxes ! (? BindSyntaxes)) - (make b:defstx $2 $3 $5 $6)]) - - ;; BindSyntaxes Answer = Derivation - (BindSyntaxes - (#:wrap) - [(phase-up (? EE/LetLifts) (? Eval)) - (make bind-syntaxes $2 $3)]) - - ;; NextBindSyntaxess Answer = (list-of Derivation) - (NextBindSyntaxess - (#:no-wrap) - (#:skipped null) - [() null] - [(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)]) - - ;; Lists - ;; EL Answer = ListDerivation - (EL - (#:wrap) - (#:skipped #f) - [(enter-list ! (? EL*) exit-list) - ;; FIXME: Workaround for bug in events - (if (null? $3) - (make lderiv null null $2 $3) - (make lderiv $1 $4 $2 $3))]) - - ;; EL* Answer = (listof Derivation) - (EL* - (#:no-wrap) - (#:skipped null) - [() null] - [(next (? EE) (? EL*)) (cons $2 $3)]) - - ))) - - ) +#lang scheme/base +(require (for-syntax scheme/base) + "yacc-ext.ss" + "yacc-interrupted.ss" + "deriv.ss" + "deriv-util.ss" + "deriv-tokens.ss") +(provide parse-derivation) + +(define (deriv-error ok? name value start end) + (if ok? + (error 'derivation-parser + "error on token #~a: <~s, ~s>" + start name value) + (error 'derivation-parser "bad token #~a" start))) + +;; PARSER + +(define (parse-derivation x) + (parameterize ((current-sequence-number 0)) + (parse-derivation* x))) + +(define current-sequence-number (make-parameter #f)) +(define (new-sequence-number) + (let ([seq (current-sequence-number)]) + (current-sequence-number (add1 seq)) + seq)) + +(define-struct (exn:eval exn) (deriv)) +(define empty-cms + (call-with-continuation-prompt (lambda () (current-continuation-marks)))) +(define (create-eval-exn deriv) + (make-exn:eval "exception during evaluation" + empty-cms + deriv)) + +(define-production-splitter production/I values values) + +(define-syntax (productions/I stx) + (syntax-case stx () + [(productions/I def ...) + #'(begin (production/I def) ...)])) + +(define parse-derivation* + (parser + (options (start Expansion) + (src-pos) + (tokens basic-tokens prim-tokens renames-tokens) + (end EOF) + (error deriv-error) + #;(debug "DEBUG-PARSER.txt")) + + ;; tokens + (skipped-token-values + visit resolve next next-group return + enter-macro macro-pre-transform macro-post-transform exit-macro + enter-prim exit-prim + enter-block block->list block->letrec splice + enter-list exit-list + enter-check exit-check + local-post exit-local exit-local/expr + phase-up module-body + renames-lambda + renames-case-lambda + renames-let + renames-letrec-syntaxes + renames-block + IMPOSSIBLE) + + ;; Entry point + (productions + (Expansion + [(start EE/Lifts) $2] + [(start EE/Lifts/Interrupted) $2])) + + (productions/I + + ;; Expand/Lifts + (EE/Lifts + (#:no-wrap) + [((? EE)) $1] + [((? EE/Lifts+)) $1]) + + (EE/Lifts+ + (#:no-wrap) + [(EE lift-loop (? EE/Lifts)) + (let ([e1 (wderiv-e1 $1)] + [e2 (wderiv-e2 $3)]) + (make lift-deriv e1 e2 $1 $2 $3))]) + + ;; Expansion of an expression + ;; EE Answer = Derivation (I) + (EE + (#:no-wrap) + [(visit (? PrimStep) return) + ($2 $1 $3)] + [((? EE/Macro)) + $1]) + + (EE/Macro + (#:wrap) + [(visit (? MacroStep) (? EE)) + (make mrule $1 (and $3 (wderiv-e2 $3)) $2 $3)]) + + ;; Expand/LetLifts + ;; Used for expand_lift_to_let (rhs of define-syntaxes, mostly) + (EE/LetLifts + (#:no-wrap) + [((? EE)) $1] + [((? EE/LetLifts+)) $1]) + + (EE/LetLifts+ + (#:wrap) + [(EE lift/let-loop (? EE/LetLifts)) + (let ([initial (wderiv-e1 $1)] + [final (wderiv-e2 $3)]) + (make lift/let-deriv initial final $1 $2 $3))]) + + ;; Evaluation + ;; Answer = ?exn + (Eval + (#:no-wrap) + [() #f] + [(!!) $1] + [(start EE/Interrupted) (create-eval-exn $2)] + [(start EE (? Eval)) $3] + [(start CheckImmediateMacro/Interrupted) (create-eval-exn $2)] + [(start CheckImmediateMacro (? Eval)) $3]) + + ;; Expansion of an expression to primitive form + (CheckImmediateMacro + (#:no-wrap) + [(enter-check (? CheckImmediateMacro/Inner) exit-check) + ($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))]) + (CheckImmediateMacro/Inner + (#:args e1 e2 k) + (#:wrap) + [() + (k e1 e2)] + [(visit (? MacroStep) return (? CheckImmediateMacro/Inner)) + (let ([next ($4 $3 e2 k)]) + (make mrule $1 (and next (wderiv-e2 next)) $2 next))]) + + ;; Expansion of multiple expressions, next-separated + (NextEEs + (#:no-wrap) + (#:skipped null) + [() null] + [(next (? EE) (? NextEEs)) (cons $2 $3)]) + + ;; Keyword resolution + (Resolves + (#:no-wrap) + [() null] + [(resolve Resolves) (cons $1 $2)]) + + ;; Single macro step (may contain local-expand calls) + ;; MacroStep Answer = Transformation (I,E) + (MacroStep + (#:wrap) + [(Resolves enter-macro ! macro-pre-transform (? LocalActions) + ! macro-post-transform exit-macro) + (make transformation $2 $8 $1 $3 $4 $5 $6 $7 (new-sequence-number))]) + + ;; Local actions taken by macro + ;; LocalAction Answer = (list-of LocalAction) + (LocalActions + (#:no-wrap) + (#:skipped null) + [() null] + [((? LocalAction) (? LocalActions)) (cons $1 $2)] + [((? NotReallyLocalAction) (? LocalActions)) $2]) + + (LocalAction + (#:no-wrap) + [(enter-local local-pre start (? EE) local-post exit-local) + (make local-expansion $1 $6 $2 $5 #f $4)] + [(enter-local phase-up local-pre start (? EE) local-post exit-local) + (make local-expansion $1 $7 $3 $6 #t $5)] + [(enter-local/expr local-pre start (? EE) local-post exit-local/expr) + (make local-expansion/expr $1 (car $6) $2 $5 #f (cdr $6) $4)] + [(enter-local/expr local-pre phase-up start (? EE) local-post exit-local/expr) + (make local-expansion/expr $1 (car $7) $3 $6 #t (cdr $7) $5)] + [(lift) + (make local-lift (cdr $1) (car $1))] + [(lift-statement) + (make local-lift-end $1)] + [((? BindSyntaxes)) + (make local-bind $1)]) + + (NotReallyLocalAction + (#:no-wrap) + ;; called 'expand' (not 'local-expand') within transformer + [(start (? EE)) + (make local-expansion (wderiv-e1 $2) + (wderiv-e2 $2) + (wderiv-e1 $2) + (wderiv-e2 $2) + #f + $2)]) + + ;; Primitive + (PrimStep + (#:args e1 e2) + (#:no-wrap) + [(Resolves (? PrimError)) + ($2 e1 e2 $1)] + [(Resolves Variable) + ($2 e1 e2 $1)] + [(Resolves enter-prim (? Prim) exit-prim) + ($3 e1 e2 $1)] + [(Resolves enter-prim (? TaggedPrim) exit-prim) + ($3 e1 $4 $1 $2)]) + + (PrimError + (#:args e1 e2 rs) + (#:wrap) + [(! IMPOSSIBLE) + (make p:unknown e1 e2 rs $1)]) + + (Variable + (#:args e1 e2 rs) + (#:wrap) + [(variable) + (make p:variable e1 e2 rs #f)]) + + (TaggedPrim + (#:args e1 e2 rs tagged-stx) + (#:no-wrap) + [((? Prim#%App)) ($1 e1 e2 rs tagged-stx)] + [((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)] + [((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)]) + + (Prim + (#:args e1 e2 rs) + (#:no-wrap) + [((? PrimModule)) ($1 e1 e2 rs)] + [((? Prim#%ModuleBegin)) ($1 e1 e2 rs)] + [((? PrimDefineSyntaxes)) ($1 e1 e2 rs)] + [((? PrimDefineValues)) ($1 e1 e2 rs)] + [((? PrimExpression)) ($1 e1 e2 rs)] + [((? PrimIf)) ($1 e1 e2 rs)] + [((? PrimWCM)) ($1 e1 e2 rs)] + [((? PrimSet)) ($1 e1 e2 rs)] + [((? PrimBegin)) ($1 e1 e2 rs)] + [((? PrimBegin0)) ($1 e1 e2 rs)] + [((? PrimLambda)) ($1 e1 e2 rs)] + [((? PrimCaseLambda)) ($1 e1 e2 rs)] + [((? PrimLetValues)) ($1 e1 e2 rs)] + [((? PrimLet*Values)) ($1 e1 e2 rs)] + [((? PrimLetrecValues)) ($1 e1 e2 rs)] + [((? PrimLetrecSyntaxes+Values)) ($1 e1 e2 rs)] + [((? PrimSTOP)) ($1 e1 e2 rs)] + [((? PrimQuote)) ($1 e1 e2 rs)] + [((? PrimQuoteSyntax)) ($1 e1 e2 rs)] + [((? PrimRequire)) ($1 e1 e2 rs)] + [((? PrimRequireForSyntax)) ($1 e1 e2 rs)] + [((? PrimRequireForTemplate)) ($1 e1 e2 rs)] + [((? PrimProvide)) ($1 e1 e2 rs)]) + + (PrimModule + (#:args e1 e2 rs) + (#:wrap) + ;; Multiple forms after language: tagging done automatically + [(prim-module (? Eval) (? EE)) + (make p:module e1 e2 rs $2 #f #f #f $3)] + ;; One form after language: macro that expands into #%module-begin + [(prim-module Eval next (? CheckImmediateMacro) next ! (? EE)) + (make p:module e1 e2 rs #f #t $4 $6 $7)]) + + (Prim#%ModuleBegin + (#:args e1 e2 rs) + (#:wrap) + [(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !) + (make p:#%module-begin e1 e2 rs $2 $3 $5 $6)]) + + (ModulePass1 + (#:no-wrap) + (#:skipped null) + [() null] + [(next (? ModulePass1-Part) (? ModulePass1)) + (cons $2 $3)] + [(module-lift-end-loop (? ModulePass1)) + (cons (make mod:lift-end $1) $2)]) + + (ModulePass1-Part + (#:wrap) + [((? EE) (? ModulePass1/Prim)) + (make mod:prim $1 $2)] + [(EE ! splice) + (make mod:splice $1 $2 $3)] + [(EE module-lift-loop) + (make mod:lift $1 $2)]) + + (ModulePass1/Prim + (#:wrap) + [(enter-prim prim-define-values ! exit-prim) + (make p:define-values $1 $4 null $3 #f)] + [(enter-prim prim-define-syntaxes ! + phase-up (? EE/LetLifts) (? Eval) exit-prim) + (make p:define-syntaxes $1 $7 null $3 $5 $6)] + [(enter-prim prim-require (? Eval) exit-prim) + (make p:require $1 $4 null $3)] + [(enter-prim prim-require-for-syntax (? Eval) exit-prim) + (make p:require-for-syntax $1 $4 null $3)] + [(enter-prim prim-require-for-template (? Eval) exit-prim) + (make p:require-for-template $1 $4 null $3)] + [(enter-prim prim-provide ! exit-prim) + (make p:provide $1 $4 null $3)] + [() + #f]) + + (ModulePass2 + (#:no-wrap) + (#:skipped null) + [() null] + [(next (? ModulePass2-Part) (? ModulePass2)) + (cons $2 $3)] + [(module-lift-end-loop (? ModulePass2)) + (cons (make mod:lift-end $1) $2)]) + + (ModulePass2-Part + (#:no-wrap) + ;; not normal; already handled + [() + (make mod:skip)] + ;; normal: expand completely + [((? EE)) + (make mod:cons $1)] + ;; catch lifts + [(EE module-lift-loop) + (make mod:lift $1 $2)]) + + ;; Definitions + (PrimDefineSyntaxes + (#:args e1 e2 rs) + (#:wrap) + [(prim-define-syntaxes ! (? EE/LetLifts) (? Eval)) + (make p:define-syntaxes e1 e2 rs $2 $3 $4)]) + + (PrimDefineValues + (#:args e1 e2 rs) + (#:wrap) + [(prim-define-values ! (? EE)) + (make p:define-values e1 e2 rs $2 $3)]) + + ;; Simple expressions + (PrimExpression + (#:args e1 e2 rs) + (#:wrap) + [(prim-expression ! (? EE)) + (make p:#%expression e1 e2 rs $2 $3)]) + + (PrimIf + (#:args e1 e2 rs) + (#:wrap) + [(prim-if ! (? EE) next (? EE) next (? EE)) + (make p:if e1 e2 rs $2 #t $3 $5 $7)] + [(prim-if next-group (? EE) next (? EE)) + (make p:if e1 e2 rs #f #f $3 $5 #f)]) + + (PrimWCM + (#:args e1 e2 rs) + (#:wrap) + [(prim-wcm ! (? EE) next (? EE) next (? EE)) + (make p:wcm e1 e2 rs $2 $3 $5 $7)]) + + ;; Sequence-containing expressions + (PrimBegin + (#:args e1 e2 rs) + (#:wrap) + [(prim-begin ! (? EL)) + (make p:begin e1 e2 rs $2 $3)]) + + (PrimBegin0 + (#:args e1 e2 rs) + (#:wrap) + [(prim-begin0 ! next (? EE) next (? EL)) + (make p:begin0 e1 e2 rs $2 $4 $6)]) + + (Prim#%App + (#:args e1 e2 rs tagged-stx) + (#:wrap) + [(prim-#%app !) + (make p:#%app e1 e2 rs $2 tagged-stx (make lderiv null null #f null))] + [(prim-#%app (? EL)) + (make p:#%app e1 e2 rs #f tagged-stx $2)]) + + ;; Binding expressions + (PrimLambda + (#:args e1 e2 rs) + (#:wrap) + [(prim-lambda ! renames-lambda (? EB)) + (make p:lambda e1 e2 rs $2 $3 $4)]) + + (PrimCaseLambda + (#:args e1 e2 rs) + (#:wrap) + [(prim-case-lambda ! (? NextCaseLambdaClauses)) + (make p:case-lambda e1 e2 rs $2 $3)]) + + (NextCaseLambdaClauses + (#:skipped null) + (#:no-wrap) + [(next (? CaseLambdaClause) (? NextCaseLambdaClauses)) + (cons $2 $3)] + [() null]) + + (CaseLambdaClause + (#:wrap) + [(! renames-case-lambda (? EB)) + (make clc $1 $2 $3)]) + + (PrimLetValues + (#:args e1 e2 rs) + (#:wrap) + [(prim-let-values ! renames-let (? NextEEs) next-group (? EB)) + (make p:let-values e1 e2 rs $2 $3 $4 $6)]) + + (PrimLet*Values + (#:args e1 e2 rs) + (#:wrap) + ;; let*-values with bindings is "macro-like" + [(prim-let*-values !!) + (let ([tx (make transformation e1 #f rs $2 + #f null #f #f (new-sequence-number))]) + (make mrule e1 e2 tx #f))] + [(prim-let*-values (? EE)) + (let* ([next-e1 (wderiv-e1 $2)] + [tx (make transformation e1 next-e1 rs #f + e1 null #f next-e1 (new-sequence-number))]) + (make mrule e1 e2 tx $2))] + ;; No bindings... model as "let" + [(prim-let*-values renames-let (? NextEEs) next-group (? EB)) + (make p:let-values e1 e2 rs #f $2 $3 $5)]) + + (PrimLetrecValues + (#:args e1 e2 rs) + (#:wrap) + [(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB)) + (make p:letrec-values e1 e2 rs $2 $3 $4 $6)]) + + (PrimLetrecSyntaxes+Values + (#:args e1 e2 rs) + (#:wrap) + [(prim-letrec-syntaxes+values ! renames-letrec-syntaxes + (? NextBindSyntaxess) next-group (? EB)) + (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)] + [(prim-letrec-syntaxes+values renames-letrec-syntaxes + NextBindSyntaxess next-group + prim-letrec-values + renames-let (? NextEEs) next-group (? EB)) + (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9)]) + + ;; Atomic expressions + (Prim#%Datum + (#:args e1 e2 rs tagged-stx) + (#:wrap) + [(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)]) + + (Prim#%Top + (#:args e1 e2 rs tagged-stx) + (#:wrap) + [(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)]) + + (PrimSTOP + (#:args e1 e2 rs) + (#:wrap) + [(prim-stop !) (make p:stop e1 e2 rs $2)]) + + (PrimQuote + (#:args e1 e2 rs) + (#:wrap) + [(prim-quote !) (make p:quote e1 e2 rs $2)]) + + (PrimQuoteSyntax + (#:args e1 e2 rs) + (#:wrap) + [(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)]) + + (PrimRequire + (#:args e1 e2 rs) + (#:wrap) + [(prim-require (? Eval)) + (make p:require e1 e2 rs $2)]) + + (PrimRequireForSyntax + (#:args e1 e2 rs) + (#:wrap) + [(prim-require-for-syntax (? Eval)) + (make p:require-for-syntax e1 e2 rs $2)]) + + (PrimRequireForTemplate + (#:args e1 e2 rs) + (#:wrap) + [(prim-require-for-template (? Eval)) + (make p:require-for-template e1 e2 rs $2)]) + + (PrimProvide + (#:args e1 e2 rs) + (#:wrap) + [(prim-provide !) (make p:provide e1 e2 rs $2)]) + + (PrimSet + (#:args e1 e2 rs) + (#:wrap) + [(prim-set! ! Resolves next (? EE)) + (make p:set! e1 e2 rs $2 $3 $5)] + [(prim-set! (? MacroStep) (? EE)) + (make p:set!-macro e1 e2 rs #f + (make mrule e1 (and $3 (wderiv-e2 $3)) $2 $3))]) + + ;; Blocks + ;; EB Answer = BlockDerivation + (EB + (#:wrap) + [(enter-block (? BlockPass1) block->list (? EL)) + (make bderiv $1 (and $4 (wlderiv-es2 $4)) + $2 'list $4)] + [(enter-block BlockPass1 block->letrec (? EL)) + (make bderiv $1 (and $4 (wlderiv-es2 $4)) + $2 'letrec $4)]) + + ;; BlockPass1 Answer = (list-of BRule) + (BlockPass1 + (#:no-wrap) + (#:skipped null) + [() null] + [((? BRule) (? BlockPass1)) + (cons $1 $2)]) + + ;; BRule Answer = BRule + (BRule + (#:wrap) + [(next !!) + (make b:error $2)] + [(next renames-block (? CheckImmediateMacro)) + (make b:expr $2 $3)] + [(next renames-block CheckImmediateMacro prim-begin ! splice !) + (make b:splice $2 $3 $5 $6 $7)] + [(next renames-block CheckImmediateMacro prim-define-values !) + (make b:defvals $2 $3 $5)] + [(next renames-block CheckImmediateMacro + prim-define-syntaxes ! (? BindSyntaxes)) + (make b:defstx $2 $3 $5 $6)]) + + ;; BindSyntaxes Answer = Derivation + (BindSyntaxes + (#:wrap) + [(phase-up (? EE/LetLifts) (? Eval)) + (make bind-syntaxes $2 $3)]) + + ;; NextBindSyntaxess Answer = (list-of Derivation) + (NextBindSyntaxess + (#:no-wrap) + (#:skipped null) + [() null] + [(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)]) + + ;; Lists + ;; EL Answer = ListDerivation + (EL + (#:wrap) + (#:skipped #f) + [(enter-list ! (? EL*) exit-list) + ;; FIXME: Workaround for bug in events + (if (null? $3) + (make lderiv null null $2 $3) + (make lderiv $1 $4 $2 $3))]) + + ;; EL* Answer = (listof Derivation) + (EL* + (#:no-wrap) + (#:skipped null) + [() null] + [(next (? EE) (? EL*)) (cons $2 $3)]) + + ))) diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss index 7b34f08..7cf5f05 100644 --- a/collects/macro-debugger/model/deriv-tokens.ss +++ b/collects/macro-debugger/model/deriv-tokens.ss @@ -1,160 +1,158 @@ -(module deriv-tokens mzscheme - (require (lib "lex.ss" "parser-tools") - "deriv.ss") - (provide (all-defined)) +#lang scheme/base +(require parser-tools/lex + "deriv.ss") +(provide (all-defined-out)) - (define-tokens basic-tokens - (start ; . - visit ; syntax - resolve ; identifier - next ; . - next-group ; . - enter-macro ; syntax - macro-pre-transform ; syntax - macro-post-transform ; syntax - exit-macro ; syntax - enter-prim ; syntax - exit-prim ; syntax - return ; syntax - enter-block ; syntaxes - block->list ; syntaxes - block->letrec ; syntax(es?) - splice ; syntaxes - enter-list ; syntaxes - exit-list ; syntaxes - enter-check ; syntax - exit-check ; syntax - phase-up ; . - module-body ; (list-of (cons syntax boolean)) - ... ; . - EOF ; . - syntax-error ; exn - lift-loop ; syntax - lift/let-loop ; syntax - module-lift-loop ; syntaxes - module-lift-end-loop ; syntaxes - lift ; (cons syntax id) - lift-statement ; syntax - enter-local ; syntax - local-pre ; syntax - local-post ; syntax - exit-local ; syntax +(define-tokens basic-tokens + (start ; . + visit ; syntax + resolve ; identifier + next ; . + next-group ; . + enter-macro ; syntax + macro-pre-transform ; syntax + macro-post-transform ; syntax + exit-macro ; syntax + enter-prim ; syntax + exit-prim ; syntax + return ; syntax + enter-block ; syntaxes + block->list ; syntaxes + block->letrec ; syntax(es?) + splice ; syntaxes + enter-list ; syntaxes + exit-list ; syntaxes + enter-check ; syntax + exit-check ; syntax + phase-up ; . + module-body ; (list-of (cons syntax boolean)) + ... ; . + EOF ; . + syntax-error ; exn + lift-loop ; syntax + lift/let-loop ; syntax + module-lift-loop ; syntaxes + module-lift-end-loop ; syntaxes + lift ; (cons syntax id) + lift-statement ; syntax + enter-local ; syntax + local-pre ; syntax + local-post ; syntax + exit-local ; syntax - enter-local/expr ; syntax - exit-local/expr ; (cons syntax expanded-expression) + enter-local/expr ; syntax + exit-local/expr ; (cons syntax expanded-expression) - variable ; (cons identifier identifier) + variable ; (cons identifier identifier) - IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart - )) + IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart + )) - (define-tokens renames-tokens - (renames-lambda ; (cons syntax syntax) - renames-case-lambda ; (cons syntax syntax) - renames-let ; (cons (listof syntax) syntax) - renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax)) - renames-block ; (cons syntax syntax) ... different, contains both pre+post - )) +(define-tokens renames-tokens + (renames-lambda ; (cons syntax syntax) + renames-case-lambda ; (cons syntax syntax) + renames-let ; (cons (listof syntax) syntax) + renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax)) + renames-block ; (cons syntax syntax) ... different, contains both pre+post + )) - ;; Empty tokens - (define-tokens prim-tokens - (prim-module prim-#%module-begin - prim-define-syntaxes prim-define-values - prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda - prim-case-lambda prim-let-values prim-let*-values prim-letrec-values - prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop - prim-quote prim-quote-syntax prim-require prim-require-for-syntax - prim-require-for-template prim-provide - prim-set! - prim-expression - )) +;; Empty tokens +(define-tokens prim-tokens + (prim-module prim-#%module-begin + prim-define-syntaxes prim-define-values + prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda + prim-case-lambda prim-let-values prim-let*-values prim-letrec-values + prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop + prim-quote prim-quote-syntax prim-require prim-require-for-syntax + prim-require-for-template prim-provide + prim-set! + prim-expression + )) - ;; ** Signals to tokens +;; ** Signals to tokens - (define signal-mapping - `((EOF . EOF) - (error . ,token-syntax-error) - (0 . ,token-visit) - (1 . ,token-resolve) - (2 . ,token-return) - (3 . ,token-next) - (4 . ,token-enter-list) - (5 . ,token-exit-list) - (6 . ,token-enter-prim) - (7 . ,token-exit-prim) - (8 . ,token-enter-macro) - (9 . ,token-exit-macro) - (10 . ,token-enter-block) - (11 . ,token-splice) - (12 . ,token-block->list) - (13 . ,token-next-group) - (14 . ,token-block->letrec) - (16 . ,token-renames-let) - (17 . ,token-renames-lambda) - (18 . ,token-renames-case-lambda) - (19 . ,token-renames-letrec-syntaxes) - (20 . phase-up) - (21 . ,token-macro-pre-transform) - (22 . ,token-macro-post-transform) - (23 . ,token-module-body) - (24 . ,token-renames-block) - - (100 . prim-stop) - (101 . prim-module) - (102 . prim-#%module-begin) - (103 . prim-define-syntaxes) - (104 . prim-define-values) - (105 . prim-if) - (106 . prim-wcm) - (107 . prim-begin) - (108 . prim-begin0) - (109 . prim-#%app) - (110 . prim-lambda) - (111 . prim-case-lambda) - (112 . prim-let-values) - (113 . prim-letrec-values) - (114 . prim-letrec-syntaxes+values) - (115 . prim-#%datum) - (116 . prim-#%top) - (117 . prim-quote) - (118 . prim-quote-syntax) - (119 . prim-require) - (120 . prim-require-for-syntax) - (121 . prim-require-for-template) - (122 . prim-provide) - (123 . prim-set!) - (124 . prim-let*-values) - (125 . ,token-variable) - (126 . ,token-enter-check) - (127 . ,token-exit-check) - (128 . ,token-lift-loop) - (129 . ,token-lift) - (130 . ,token-enter-local) - (131 . ,token-exit-local) - (132 . ,token-local-pre) - (133 . ,token-local-post) - (134 . ,token-lift-statement) - (135 . ,token-module-lift-end-loop) - (136 . ,token-lift/let-loop) - (137 . ,token-module-lift-loop) - (138 . prim-expression) - (139 . ,token-enter-local/expr) - (140 . ,token-exit-local/expr) - (141 . ,token-start) - )) +(define signal-mapping + `((EOF . EOF) + (error . ,token-syntax-error) + (0 . ,token-visit) + (1 . ,token-resolve) + (2 . ,token-return) + (3 . ,token-next) + (4 . ,token-enter-list) + (5 . ,token-exit-list) + (6 . ,token-enter-prim) + (7 . ,token-exit-prim) + (8 . ,token-enter-macro) + (9 . ,token-exit-macro) + (10 . ,token-enter-block) + (11 . ,token-splice) + (12 . ,token-block->list) + (13 . ,token-next-group) + (14 . ,token-block->letrec) + (16 . ,token-renames-let) + (17 . ,token-renames-lambda) + (18 . ,token-renames-case-lambda) + (19 . ,token-renames-letrec-syntaxes) + (20 . phase-up) + (21 . ,token-macro-pre-transform) + (22 . ,token-macro-post-transform) + (23 . ,token-module-body) + (24 . ,token-renames-block) + + (100 . prim-stop) + (101 . prim-module) + (102 . prim-#%module-begin) + (103 . prim-define-syntaxes) + (104 . prim-define-values) + (105 . prim-if) + (106 . prim-wcm) + (107 . prim-begin) + (108 . prim-begin0) + (109 . prim-#%app) + (110 . prim-lambda) + (111 . prim-case-lambda) + (112 . prim-let-values) + (113 . prim-letrec-values) + (114 . prim-letrec-syntaxes+values) + (115 . prim-#%datum) + (116 . prim-#%top) + (117 . prim-quote) + (118 . prim-quote-syntax) + (119 . prim-require) + (120 . prim-require-for-syntax) + (121 . prim-require-for-template) + (122 . prim-provide) + (123 . prim-set!) + (124 . prim-let*-values) + (125 . ,token-variable) + (126 . ,token-enter-check) + (127 . ,token-exit-check) + (128 . ,token-lift-loop) + (129 . ,token-lift) + (130 . ,token-enter-local) + (131 . ,token-exit-local) + (132 . ,token-local-pre) + (133 . ,token-local-post) + (134 . ,token-lift-statement) + (135 . ,token-module-lift-end-loop) + (136 . ,token-lift/let-loop) + (137 . ,token-module-lift-loop) + (138 . prim-expression) + (139 . ,token-enter-local/expr) + (140 . ,token-exit-local/expr) + (141 . ,token-start) + )) - (define (tokenize sig-n val pos) - (let ([p (assv sig-n signal-mapping)]) - (if (pair? p) - (make-position-token - (cond [(procedure? (cdr p)) ((cdr p) val)] - [(symbol? (cdr p)) (cdr p)]) - pos - pos) - (error 'tokenize "bad signal: ~s" sig-n)))) +(define (tokenize sig-n val pos) + (let ([p (assv sig-n signal-mapping)]) + (if (pair? p) + (make-position-token + (cond [(procedure? (cdr p)) ((cdr p) val)] + [(symbol? (cdr p)) (cdr p)]) + pos + pos) + (error 'tokenize "bad signal: ~s" sig-n)))) - (define (signal->symbol sig-n) - (cdr (assv sig-n signal-mapping))) - - ) +(define (signal->symbol sig-n) + (cdr (assv sig-n signal-mapping))) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index d839d43..951dd2c 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -1,100 +1,100 @@ -(module deriv-util mzscheme - (require "deriv.ss" - (lib "list.ss") - (lib "plt-match.ss")) - (require-for-syntax (lib "scheme/private/struct-info.ss")) +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax scheme/private/struct-info) + scheme/list + scheme/match + "deriv.ss") - (provide make +(provide make - Wrap - - ok-node? - interrupted-node? + Wrap + + ok-node? + interrupted-node? - wderiv-e1 - wderiv-e2 - wlderiv-es1 - wlderiv-es2 - wbderiv-es1 - wbderiv-es2 + 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 ...)))]))) + wderivlist-es2) - ;; ---- - - (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))) - - ;; ---- - - (define-syntax (make stx) +;; Wrap matcher +;; Matches unwrapped, interrupted wrapped, or error wrapped +(define-match-expander Wrap + (lambda (stx) (syntax-case stx () - [(make S expr ...) - (unless (identifier? #'S) - (raise-syntax-error #f "not an identifier" stx #'S)) - (let () - (define (no-info) (raise-syntax-error #f "not a struct" stx #'S)) - (define info - (extract-struct-info - (syntax-local-value #'S no-info))) - (define constructor (list-ref info 1)) - (define accessors (list-ref info 3)) - (unless (identifier? #'constructor) - (raise-syntax-error #f "constructor not available for struct" stx #'S)) - (unless (andmap identifier? accessors) - (raise-syntax-error #f "incomplete info for struct type" stx #'S)) - (let ([num-slots (length accessors)] - [num-provided (length (syntax->list #'(expr ...)))]) - (unless (= num-provided num-slots) - (raise-syntax-error - #f - (format "wrong number of arguments for struct ~s (expected ~s)" - (syntax-e #'S) - num-slots) - stx))) - (with-syntax ([constructor constructor]) - #'(constructor expr ...)))])) - ) + [(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))) + +;; ---- + +(define-syntax (make stx) + (syntax-case stx () + [(make S expr ...) + (unless (identifier? #'S) + (raise-syntax-error #f "not an identifier" stx #'S)) + (let () + (define (no-info) (raise-syntax-error #f "not a struct" stx #'S)) + (define info + (extract-struct-info + (syntax-local-value #'S no-info))) + (define constructor (list-ref info 1)) + (define accessors (list-ref info 3)) + (unless (identifier? #'constructor) + (raise-syntax-error #f "constructor not available for struct" stx #'S)) + (unless (andmap identifier? accessors) + (raise-syntax-error #f "incomplete info for struct type" stx #'S)) + (let ([num-slots (length accessors)] + [num-provided (length (syntax->list #'(expr ...)))]) + (unless (= num-provided num-slots) + (raise-syntax-error + #f + (format "wrong number of arguments for struct ~s (expected ~s)" + (syntax-e #'S) + num-slots) + stx))) + (with-syntax ([constructor constructor]) + #'(constructor expr ...)))])) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss index ffe82aa..21c1eab 100644 --- a/collects/macro-debugger/model/deriv.ss +++ b/collects/macro-debugger/model/deriv.ss @@ -1,370 +1,368 @@ -(module deriv mzscheme - (require (lib "contract.ss") - (lib "stx.ss" "syntax") - "deriv-c.ss") +#lang scheme/base +(require scheme/contract + syntax/stx + "deriv-c.ss") - ;; NO CONTRACTS - - #;(provide (all-from "deriv-c.ss")) +(provide (all-from-out "deriv-c.ss")) - ;; CONTRACTS - - (define (?? c) (or/c c false/c)) +#| - (define (stx? x) - (or (syntax? x) - (and (pair? x) (stx? (car x)) (stx? (cdr x))) - (null? x))) - - (define (stx-list-like? x) - (let ([x (stx->list x)]) - (and x (andmap syntax? x)))) +(define (?? c) (or/c c false/c)) - (define syntax/f (?? syntax?)) - (define syntaxes/c stx-list-like?) - (define syntaxes/f (?? syntaxes/c)) - (define resolves/c (listof identifier?)) +(define (stx? x) + (or (syntax? x) + (and (pair? x) (stx? (car x)) (stx? (cdr x))) + (null? x))) - (define localaction/c - (or/c local-expansion? local-expansion/expr? local-lift? - local-lift-end? local-bind?)) - - (provide/contract - (struct node - ([z1 any/c] - [z2 any/c])) - (struct (deriv node) - ([z1 syntax?] - [z2 syntax/f])) - (struct (lift-deriv deriv) - ([z1 syntax?] - [z2 syntax/f] - [first deriv?] - [lift-stx syntax?] - [second deriv?])) - (struct (mrule deriv) - ([z1 syntax?] - [z2 syntax/f] - [transformation transformation?] - [next (?? deriv?)])) - (struct (lift/let-deriv deriv) - ([z1 syntax?] - [z2 syntax/f] - [first deriv?] - [lift-stx syntax?] - [second deriv?])) - (struct (transformation node) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [me1 (?? syntax?)] - [locals (?? (listof localaction/c))] - [?2 (?? exn?)] - [me2 (?? syntax?)] - [seq number?])) - (struct (local-expansion node) - ([z1 syntax?] - [z2 syntax/f] - [me1 syntax?] - [me2 syntax/f] - [for-stx? boolean?] - [inner deriv?])) - (struct (local-expansion/expr node) - ([z1 syntax?] - [z2 syntax/f] - [me1 syntax?] - [me2 syntax/f] - [for-stx? boolean?] - [opaque any/c] - [inner deriv?])) - (struct local-lift - ([expr syntax?] - [id identifier?])) - (struct local-lift-end - ([decl syntax?])) - (struct local-bind - ([bindrhs bind-syntaxes?])) - (struct (base deriv) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (prule base) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:variable prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:module prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [one-body-form? boolean?] - [mb (?? deriv?)] - [?2 (?? exn?)] - [body (?? deriv?)])) - (struct (p:#%module-begin prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [pass1 (?? (listof modrule?))] - [pass2 (?? (listof modrule?))] - [?2 (?? exn?)])) - (struct (p:define-syntaxes prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [rhs (?? deriv?)] - [?2 (?? exn?)])) - (struct (p:define-values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [rhs (?? deriv?)])) - (struct (p:#%expression prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [inner (?? deriv?)])) - (struct (p:if prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [full? boolean?] - [test (?? deriv?)] - [then (?? deriv?)] - [else (?? deriv?)])) - (struct (p:wcm prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [key (?? deriv?)] - [mark (?? deriv?)] - [body (?? deriv?)])) - (struct (p:set! prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [id-resolves (?? resolves/c)] - [rhs (?? deriv?)])) - (struct (p:set!-macro prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [deriv (?? deriv?)])) - (struct (p:#%app prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [tagged-stx syntax/f] - [lderiv (?? lderiv?)])) - (struct (p:begin prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [lderiv (?? lderiv?)])) - (struct (p:begin0 prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [first (?? deriv?)] - [lderiv (?? lderiv?)])) - (struct (p:lambda prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] ;; fixme - [body (?? bderiv?)])) - (struct (p:case-lambda prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames+bodies (listof clc?)])) - (struct (p:let-values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] ;; fixme - [rhss (?? (listof deriv?))] - [body (?? bderiv?)])) - (struct (p:letrec-values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] ;; fixme - [rhss (?? (listof deriv?))] - [body (?? bderiv?)])) - (struct (p:letrec-syntaxes+values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [srenames any/c] ;; fixme - [sbindrhss (?? (listof bind-syntaxes?))] - [vrenames any/c] ;; fixme - [vrhss (?? (listof deriv?))] - [body (?? bderiv?)])) - (struct (p::STOP prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:stop p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:unknown p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:#%top p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [tagged-stx syntax/f])) - (struct (p:#%datum p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [tagged-stx syntax/f])) - (struct (p:quote p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:quote-syntax p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:require p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:require-for-syntax p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:require-for-template p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:provide p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:rename prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] - [inner (?? deriv?)])) - (struct (p:synth prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [subterms (?? (listof subitem?))] - [?2 (?? exn?)])) +(define (stx-list-like? x) + (let ([x (stx->list x)]) + (and x (andmap syntax? x)))) - (struct (lderiv node) - ([z1 stx?] - [z2 syntaxes/f] - [?1 (?? exn?)] - [derivs (?? (listof deriv?))])) - (struct (bderiv node) - ([z1 stx?] - [z2 syntaxes/f] - [pass1 (?? (listof (or/c b:error? brule?)))] - [trans (symbols 'list 'letrec)] - [pass2 (?? lderiv?)])) +(define syntax/f (?? syntax?)) +(define syntaxes/c stx-list-like?) +(define syntaxes/f (?? syntaxes/c)) +(define resolves/c (listof identifier?)) - (struct b:error - ([?1 exn?])) - (struct brule - ([renames any/c])) - (struct (b:expr brule) - ([renames any/c] - [head deriv?])) - (struct (b:splice brule) - ([renames any/c] - [head deriv?] - [?1 (?? exn?)] - [tail (?? stx?)] - [?2 (?? exn?)])) - (struct (b:defvals brule) - ([renames any/c] - [head deriv?] - [?1 (?? exn?)])) - (struct (b:defstx brule) - ([renames any/c] - [head deriv?] - [?1 (?? exn?)] - [bindrhs (?? bind-syntaxes?)])) +(define localaction/c + (or/c local-expansion? local-expansion/expr? local-lift? + local-lift-end? local-bind?)) - (struct bind-syntaxes - ([rhs deriv?] - [?1 (?? exn?)])) +(provide/contract + (struct node + ([z1 any/c] + [z2 any/c])) + (struct (deriv node) + ([z1 syntax?] + [z2 syntax/f])) + (struct (lift-deriv deriv) + ([z1 syntax?] + [z2 syntax/f] + [first deriv?] + [lift-stx syntax?] + [second deriv?])) + (struct (mrule deriv) + ([z1 syntax?] + [z2 syntax/f] + [transformation transformation?] + [next (?? deriv?)])) + (struct (lift/let-deriv deriv) + ([z1 syntax?] + [z2 syntax/f] + [first deriv?] + [lift-stx syntax?] + [second deriv?])) + (struct (transformation node) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [me1 (?? syntax?)] + [locals (?? (listof localaction/c))] + [?2 (?? exn?)] + [me2 (?? syntax?)] + [seq number?])) + (struct (local-expansion node) + ([z1 syntax?] + [z2 syntax/f] + [me1 syntax?] + [me2 syntax/f] + [for-stx? boolean?] + [inner deriv?])) + (struct (local-expansion/expr node) + ([z1 syntax?] + [z2 syntax/f] + [me1 syntax?] + [me2 syntax/f] + [for-stx? boolean?] + [opaque any/c] + [inner deriv?])) + (struct local-lift + ([expr syntax?] + [id identifier?])) + (struct local-lift-end + ([decl syntax?])) + (struct local-bind + ([bindrhs bind-syntaxes?])) + (struct (base deriv) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (prule base) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:variable prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:module prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [one-body-form? boolean?] + [mb (?? deriv?)] + [?2 (?? exn?)] + [body (?? deriv?)])) + (struct (p:#%module-begin prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [pass1 (?? (listof modrule?))] + [pass2 (?? (listof modrule?))] + [?2 (?? exn?)])) + (struct (p:define-syntaxes prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [rhs (?? deriv?)] + [?2 (?? exn?)])) + (struct (p:define-values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [rhs (?? deriv?)])) + (struct (p:#%expression prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [inner (?? deriv?)])) + (struct (p:if prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [full? boolean?] + [test (?? deriv?)] + [then (?? deriv?)] + [else (?? deriv?)])) + (struct (p:wcm prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [key (?? deriv?)] + [mark (?? deriv?)] + [body (?? deriv?)])) + (struct (p:set! prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [id-resolves (?? resolves/c)] + [rhs (?? deriv?)])) + (struct (p:set!-macro prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [deriv (?? deriv?)])) + (struct (p:#%app prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [tagged-stx syntax/f] + [lderiv (?? lderiv?)])) + (struct (p:begin prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [lderiv (?? lderiv?)])) + (struct (p:begin0 prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [first (?? deriv?)] + [lderiv (?? lderiv?)])) + (struct (p:lambda prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] ;; fixme + [body (?? bderiv?)])) + (struct (p:case-lambda prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames+bodies (listof clc?)])) + (struct (p:let-values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] ;; fixme + [rhss (?? (listof deriv?))] + [body (?? bderiv?)])) + (struct (p:letrec-values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] ;; fixme + [rhss (?? (listof deriv?))] + [body (?? bderiv?)])) + (struct (p:letrec-syntaxes+values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [srenames any/c] ;; fixme + [sbindrhss (?? (listof bind-syntaxes?))] + [vrenames any/c] ;; fixme + [vrhss (?? (listof deriv?))] + [body (?? bderiv?)])) + (struct (p::STOP prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:stop p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:unknown p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:#%top p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [tagged-stx syntax/f])) + (struct (p:#%datum p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [tagged-stx syntax/f])) + (struct (p:quote p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:quote-syntax p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:require p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:require-for-syntax p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:require-for-template p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:provide p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:rename prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] + [inner (?? deriv?)])) + (struct (p:synth prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [subterms (?? (listof subitem?))] + [?2 (?? exn?)])) - (struct clc - ([?1 (?? exn?)] - [renames any/c] - [body (?? bderiv?)])) + (struct (lderiv node) + ([z1 stx?] + [z2 syntaxes/f] + [?1 (?? exn?)] + [derivs (?? (listof deriv?))])) + (struct (bderiv node) + ([z1 stx?] + [z2 syntaxes/f] + [pass1 (?? (listof (or/c b:error? brule?)))] + [trans (symbols 'list 'letrec)] + [pass2 (?? lderiv?)])) - (struct modrule ()) - (struct (mod:cons modrule) - ([head deriv?])) - (struct (mod:prim modrule) - ([head deriv?] - [prim (?? deriv?)])) - (struct (mod:skip modrule) ()) - (struct (mod:splice modrule) - ([head deriv?] - [?1 (?? exn?)] - [tail (?? stx?)])) - (struct (mod:lift modrule) - ([head deriv?] - [tail syntaxes/c])) - (struct (mod:lift-end modrule) - ([tail syntaxes/c])) + (struct b:error + ([?1 exn?])) + (struct brule + ([renames any/c])) + (struct (b:expr brule) + ([renames any/c] + [head deriv?])) + (struct (b:splice brule) + ([renames any/c] + [head deriv?] + [?1 (?? exn?)] + [tail (?? stx?)] + [?2 (?? exn?)])) + (struct (b:defvals brule) + ([renames any/c] + [head deriv?] + [?1 (?? exn?)])) + (struct (b:defstx brule) + ([renames any/c] + [head deriv?] + [?1 (?? exn?)] + [bindrhs (?? bind-syntaxes?)])) - (struct subitem ()) - (struct (s:subterm subitem) - ([path any/c] - [deriv deriv?])) - (struct (s:rename subitem) - ([path any/c] - [before syntax?] - [after syntax?])) - )) + (struct bind-syntaxes + ([rhs deriv?] + [?1 (?? exn?)])) + + (struct clc + ([?1 (?? exn?)] + [renames any/c] + [body (?? bderiv?)])) + + (struct modrule ()) + (struct (mod:cons modrule) + ([head deriv?])) + (struct (mod:prim modrule) + ([head deriv?] + [prim (?? deriv?)])) + (struct (mod:skip modrule) ()) + (struct (mod:splice modrule) + ([head deriv?] + [?1 (?? exn?)] + [tail (?? stx?)])) + (struct (mod:lift modrule) + ([head deriv?] + [tail syntaxes/c])) + (struct (mod:lift-end modrule) + ([tail syntaxes/c])) + + (struct subitem ()) + (struct (s:subterm subitem) + ([path any/c] + [deriv deriv?])) + (struct (s:rename subitem) + ([path any/c] + [before syntax?] + [after syntax?]))) +|# diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss index 2278379..9c10ea9 100644 --- a/collects/macro-debugger/model/hiding-policies.ss +++ b/collects/macro-debugger/model/hiding-policies.ss @@ -1,100 +1,101 @@ -(module hiding-policies mzscheme - (require (lib "plt-match.ss") - (lib "boundmap.ss" "syntax")) - (provide (all-defined)) +#lang scheme/base +(require (for-syntax scheme/base) + scheme/match + syntax/boundmap) +(provide (all-defined-out)) - (define-struct hiding-policy - (opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids)) +(define-struct hiding-policy + (opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids) + #:mutable) - (define (policy-hide-module p m) - (hash-table-put! (hiding-policy-opaque-modules p) m #t)) - (define (policy-unhide-module p m) - (hash-table-remove! (hiding-policy-opaque-modules p) m)) +(define (policy-hide-module p m) + (hash-table-put! (hiding-policy-opaque-modules p) m #t)) +(define (policy-unhide-module p m) + (hash-table-remove! (hiding-policy-opaque-modules p) m)) - (define (policy-hide-kernel p) - (set-hiding-policy-opaque-kernel! p #t)) - (define (policy-unhide-kernel p) - (set-hiding-policy-opaque-kernel! p #f)) +(define (policy-hide-kernel p) + (set-hiding-policy-opaque-kernel! p #t)) +(define (policy-unhide-kernel p) + (set-hiding-policy-opaque-kernel! p #f)) - (define (policy-hide-libs p) - (set-hiding-policy-opaque-libs! p #t)) - (define (policy-unhide-libs p) - (set-hiding-policy-opaque-libs! p #f)) +(define (policy-hide-libs p) + (set-hiding-policy-opaque-libs! p #t)) +(define (policy-unhide-libs p) + (set-hiding-policy-opaque-libs! p #f)) - (define (policy-hide-id p id) - (policy-unshow-id p id) - (module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t)) - (define (policy-unhide-id p id) - (module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f)) +(define (policy-hide-id p id) + (policy-unshow-id p id) + (module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t)) +(define (policy-unhide-id p id) + (module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f)) - (define (policy-show-id p id) - (policy-unhide-id p id) - (module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #t)) - (define (policy-unshow-id p id) - (module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f)) +(define (policy-show-id p id) + (policy-unhide-id p id) + (module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #t)) +(define (policy-unshow-id p id) + (module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f)) - (define (new-hiding-policy) - (make-hiding-policy (make-hash-table) - (make-module-identifier-mapping) - #f - #f - (make-module-identifier-mapping))) - - (define (new-standard-hiding-policy) - (let ([p (new-hiding-policy)]) - (policy-hide-kernel p) - (policy-hide-libs p) - p)) +(define (new-hiding-policy) + (make-hiding-policy (make-hash-table) + (make-module-identifier-mapping) + #f + #f + (make-module-identifier-mapping))) - ;; --- - - (define-syntax inline - (syntax-rules () - [(inline ([name expr] ...) . body) - (let-syntax ([name - (lambda (x) - (syntax-case x () - [xx (identifier? #'xx) #'expr]))] ...) - . body)])) +(define (new-standard-hiding-policy) + (let ([p (new-hiding-policy)]) + (policy-hide-kernel p) + (policy-hide-libs p) + p)) - (define (/false) #f) +;; --- - (define (policy-show-macro? policy id) - (match policy - [(struct hiding-policy (opaque-modules - opaque-identifiers - opaque-kernel - opaque-libs - transparent-identifiers)) - (inline ([not-opaque-id - (not (module-identifier-mapping-get opaque-identifiers id /false))] - [transparent-id - (module-identifier-mapping-get transparent-identifiers id /false)]) - (let ([binding (identifier-binding id)]) - (if (list? binding) - (let-values ([(srcmod srcname nommod nomname _) (apply values binding)]) - (inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)] - [opaque-nommod (hash-table-get opaque-modules nommod /false)] - ;; FIXME - [in-kernel? - (and (symbol? srcmod) - (eq? #\# (string-ref (symbol->string srcmod) 0)))] - [in-lib-module? - (lib-module? srcmod)]) - (or transparent-id - (and (not opaque-srcmod) - (not opaque-nommod) - (not (and in-kernel? opaque-kernel)) - (not (and in-lib-module? opaque-libs)) - not-opaque-id)))) - (or transparent-id - not-opaque-id))))])) +(define-syntax inline + (syntax-rules () + [(inline ([name expr] ...) . body) + (let-syntax ([name + (lambda (x) + (syntax-case x () + [xx (identifier? #'xx) #'expr]))] ...) + . body)])) - (define (lib-module? mpi) - (and (module-path-index? mpi) - (let-values ([(path rel) (module-path-index-split mpi)]) - (cond [(pair? path) (memq (car path) '(lib planet))] - [(string? path) (lib-module? rel)] - [else #f])))) - ) \ No newline at end of file +(define (/false) #f) + +(define (policy-show-macro? policy id) + (match policy + [(struct hiding-policy (opaque-modules + opaque-identifiers + opaque-kernel + opaque-libs + transparent-identifiers)) + (inline ([not-opaque-id + (not (module-identifier-mapping-get opaque-identifiers id /false))] + [transparent-id + (module-identifier-mapping-get transparent-identifiers id /false)]) + (let ([binding (identifier-binding id)]) + (if (list? binding) + (let-values ([(srcmod srcname nommod nomname _) (apply values binding)]) + (inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)] + [opaque-nommod (hash-table-get opaque-modules nommod /false)] + ;; FIXME + [in-kernel? + (and (symbol? srcmod) + (eq? #\# (string-ref (symbol->string srcmod) 0)))] + [in-lib-module? + (lib-module? srcmod)]) + (or transparent-id + (and (not opaque-srcmod) + (not opaque-nommod) + (not (and in-kernel? opaque-kernel)) + (not (and in-lib-module? opaque-libs)) + not-opaque-id)))) + (or transparent-id + not-opaque-id))))])) + +(define (lib-module? mpi) + (and (module-path-index? mpi) + (let-values ([(path rel) (module-path-index-split mpi)]) + (cond [(pair? path) (memq (car path) '(lib planet))] + [(string? path) (lib-module? rel)] + [else #f])))) diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index 2b5c6a6..66b1d5d 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -1,444 +1,445 @@ +#lang scheme/base + +(require (for-syntax scheme/base) + scheme/list + scheme/contract + "deriv.ss" + "stx-util.ss" + "steps.ss") +(provide (all-from-out "steps.ss") + context + big-context + current-derivation + current-definites + learn-definites + current-frontier + add-frontier + blaze-frontier + rename-frontier + with-context + with-derivation + with-new-local-context + + RSunit + RSzero + RSbind + RSadd + RSseq + RSforeach + RS-steps + + CC + R + revappend + + walk + walk/foci + walk/mono + stumble + stumble/E) + ;; FIXME: Steps are pairs of Configurations ;; Configurations contain contexts, definites, etc. -(module reductions-engine mzscheme - (require (lib "list.ss") - "deriv.ss" - "stx-util.ss" - "steps.ss") - (require (lib "contract.ss")) - (provide (all-from "steps.ss")) +;; context: parameter of Context +(define context (make-parameter null)) - (provide context - big-context - current-derivation - current-definites - learn-definites - current-frontier - add-frontier - blaze-frontier - rename-frontier - with-context - with-derivation - with-new-local-context +;; big-context: parameter of BigContext +(define big-context (make-parameter null)) - RSunit - RSzero - RSbind - RSadd - RSseq - RSforeach - RS-steps - - CC - R - revappend) - (provide walk - walk/foci - walk/mono - stumble - stumble/E) +;; current-derivation : parameter of Derivation +(define current-derivation (make-parameter #f)) - ;; context: parameter of Context - (define context (make-parameter null)) +;; current-definites : parameter of (list-of identifier) +(define current-definites (make-parameter null)) - ;; big-context: parameter of BigContext - (define big-context (make-parameter null)) +;; current-frontier : parameter of (list-of syntax) +(define current-frontier (make-parameter null)) - ;; current-derivation : parameter of Derivation - (define current-derivation (make-parameter #f)) +(define-syntax with-context + (syntax-rules () + [(with-context f . body) + (let ([c (context)]) + (parameterize ([context (cons f c)]) + (let () . body)))])) - ;; current-definites : parameter of (list-of identifier) - (define current-definites (make-parameter null)) +(define-syntax with-derivation + (syntax-rules () + [(with-derivation d . body) + (parameterize ((current-derivation d)) . body)])) - ;; current-frontier : parameter of (list-of syntax) - (define current-frontier (make-parameter null)) +(define-syntax with-new-local-context + (syntax-rules () + [(with-new-local-context e . body) + (parameterize ([big-context + (cons (make-bigframe (current-derivation) (context) (list e) e) + (big-context))] + [context null]) + . body)])) - (define-syntax with-context - (syntax-rules () - [(with-context f . body) - (let ([c (context)]) - (parameterize ([context (cons f c)]) - (let () . body)))])) +(define (learn-definites ids) + (current-definites + (append ids (current-definites)))) - (define-syntax with-derivation - (syntax-rules () - [(with-derivation d . body) - (parameterize ((current-derivation d)) . body)])) - - (define-syntax with-new-local-context - (syntax-rules () - [(with-new-local-context e . body) - (parameterize ([big-context - (cons (make-bigframe (current-derivation) (context) (list e) e) - (big-context))] - [context null]) - . body)])) +(define (get-frontier) (or (current-frontier) null)) - (define (learn-definites ids) - (current-definites - (append ids (current-definites)))) +(define (add-frontier stxs) + (current-frontier + (let ([frontier0 (current-frontier)]) + (and frontier0 (append stxs frontier0))))) - (define (get-frontier) (or (current-frontier) null)) - - (define (add-frontier stxs) - (current-frontier - (let ([frontier0 (current-frontier)]) - (and frontier0 (append stxs frontier0))))) - - (define (blaze-frontier stx) - (current-frontier - (let ([frontier0 (current-frontier)]) - (and frontier0 - (remq stx frontier0))))) +(define (blaze-frontier stx) + (current-frontier + (let ([frontier0 (current-frontier)]) + (and frontier0 + (remq stx frontier0))))) - ;; ----------------------------------- +;; ----------------------------------- - ;; RS: The "reductions monad" - ;; (RS a) = (values ReductionSequence ?a ?exn) - ;; Not a proper monad, because of 'values' - - (define-syntax ->RS/c - (syntax-rules () - [(->RS/c domain-c ...) - (-> domain-c ... - (values (listof protostep?) any/c (or/c exn? false/c)))])) - - (define/contract RSzero - (->RS/c) - (lambda () (values null #f #f))) - - (define/contract RSunit - (->RS/c any/c) - (lambda (v) - (values null v #f))) - - (define/contract RSbind - (->RS/c (->RS/c) (->RS/c any/c)) - (lambda (a f) - (let-values ([(rseq1 final1 exn1) (a)]) - (if (not exn1) - (let-values ([(rseq2 final2 exn2) (f final1)]) - (values (append rseq1 rseq2) final2 exn2)) - (values rseq1 final1 exn1))))) +;; RS: The "reductions monad" +;; (RS a) = (values ReductionSequence ?a ?exn) +;; Not a proper monad, because of 'values' - (define/contract RSseq - (->RS/c (->RS/c) (->RS/c)) - (lambda (a b) - (RSbind a (lambda (_) (b))))) +(define-syntax ->RS/c + (syntax-rules () + [(->RS/c domain-c ...) + (-> domain-c ... + (values (listof protostep?) any/c (or/c exn? false/c)))])) - (define/contract RSforeach - (->RS/c (->RS/c any/c) (listof any/c)) - (lambda (f xs) - (let loop ([xs xs]) - (if (pair? xs) - (RSseq (lambda () (f (car xs))) - (lambda () (loop (cdr xs)))) - (RSunit (void)))))) - - (define/contract RSadd - (->RS/c (listof protostep?) (->RS/c)) - (lambda (steps a) - (let-values ([(rseq1 final1 exn1) (a)]) - (values (append steps rseq1) final1 exn1)))) +(define/contract RSzero + (->RS/c) + (lambda () (values null #f #f))) - (define-syntax RS-steps - (syntax-rules () - [(RS-steps expr) - (let-values ([(rseq final exn) expr]) - rseq)])) - - ;; CC - ;; the context constructor - (define-syntax (CC stx) - (syntax-case stx () - [(CC HOLE expr pattern) - #'(syntax-copier HOLE expr pattern)])) +(define/contract RSunit + (->RS/c any/c) + (lambda (v) + (values null v #f))) - ;; (R stx R-clause ...) - ;; An R-clause is one of - ;; [! expr] - ;; [#:pattern pattern] - ;; [#:bind pattern stx-expr] - ;; [#:let-values (var ...) expr] - ;; [#:set-syntax stx-expr] - ;; [#:walk term2 foci1 foci2 description] - ;; [#:walk term2 description] - ;; [#:rename form2 foci1 foci2 description] - ;; [#:rename/no-step pattern stx stx] - ;; [#:reductions expr] - ;; [#:learn ids] - ;; [#:frontier stxs] - ;; [#:when test R-clause ...] - ;; [#:if/np test R-clause ...] - ;; [generator hole fill] - - ;; R - ;; the threaded reductions engine +(define/contract RSbind + (->RS/c (->RS/c) (->RS/c any/c)) + (lambda (a f) + (let-values ([(rseq1 final1 exn1) (a)]) + (if (not exn1) + (let-values ([(rseq2 final2 exn2) (f final1)]) + (values (append rseq1 rseq2) final2 exn2)) + (values rseq1 final1 exn1))))) - ;; (R form . clauses) : (values (list-of Step) ?stx ?exn) +(define/contract RSseq + (->RS/c (->RS/c) (->RS/c)) + (lambda (a b) + (RSbind a (lambda (_) (b))))) - (define-syntax R - (syntax-rules () - [(R form . clauses) - (R** #f _ [#:set-syntax form] . clauses)])) - - (define-syntax R** - (syntax-rules (! =>) - ;; Base: done - [(R** form-var pattern) - (RSunit form-var)] - - ;; Base: explicit continuation - [(R** f p => k) - (k f)] - - ;; Error-point case - [(R** f p [! maybe-exn] . more) - (let ([x maybe-exn]) - (unless (or (not x) (exn? x)) - (raise-type-error 'R "exception" x)) - (if x - (values (list (stumble f x)) #f x) - (R** f p . more)))] - - ;; Change patterns - [(R** f p [#:pattern p2] . more) - (R** f p2 . more)] - - ;; Bind pattern variables - [(R** f p [#:bind pattern rhs] . more) - (with-syntax ([pattern (with-syntax ([p f]) rhs)]) - (R** f p . more))] - - ;; Bind variables - [(R** f p [#:let-values (var ...) rhs] . more) - (let-values ([(var ...) (with-syntax ([p f]) rhs)]) - (R** f p . more))] - - ;; Change syntax - [(R** f p [#:set-syntax form] . more) - (let ([form-variable form]) - (R** form-variable p . more))] - - ;; Change syntax and Step (explicit foci) - [(R** f p [#:walk form2 foci1 foci2 description] . more) - (let-values ([(form2-var foci1-var foci2-var description-var) - (with-syntax ([p f]) - (values form2 foci1 foci2 description))]) - (RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var)) - (lambda () (R** form2-var p . more))))] - - ;; Change syntax and Step (infer foci) - [(R** f p [#:walk form2 description] . more) - (let-values ([(form2-var description-var) - (with-syntax ([p f]) - (values form2 description))]) - (RSadd (list (walk f form2-var description-var)) - (lambda () (R** form2-var p . more))))] - - ;; Change syntax with rename - [(R** f p [#:rename form2 foci1 foci2 description] . more) - (let-values ([(form2-var foci1-var foci2-var description-var) - (with-syntax ([p f]) - (values form2 foci1 foci2 description))]) - (rename-frontier f form2-var) - (with-context (make-renames foci1-var foci2-var) - (RSadd (list (walk/foci foci1-var foci2-var - f form2-var - description-var)) - (lambda () (R** form2-var p . more)))))] - - ;; Change syntax with rename (but no step) - [(R** f p [#:rename/no-step pvar from to] . more) - (let-values ([(from-var to-var) - (with-syntax ([p f]) (values from to))]) - (let ([f2 (with-syntax ([p f]) - (with-syntax ([pvar to]) - (syntax p)))]) - (rename-frontier from-var to-var) - (with-context (make-renames from-var to-var) - (R** f2 p . more))))] - - ;; Add in arbitrary other steps - [(R** f p [#:reductions steps] . more) - (RSseq (lambda () steps) - (lambda () (R** f p . more)))] - - ;; Add to definites - [(R** f p [#:learn ids] . more) - (begin (learn-definites (with-syntax ([p f]) ids)) - (R** f p . more))] - - ;; Add to frontier - [(R** f p [#:frontier stxs] . more) - (begin (add-frontier (with-syntax ([p f]) stxs)) - (R** f p . more))] - - ;; Conditional (pattern changes lost afterwards ...) - [(R** f p [#:if/np test [consequent ...] [alternate ...]] . more) - (let ([continue (lambda (f2) (R** f2 p . more))]) - (if (with-syntax ([p f]) test) - (R** f p consequent ... => continue) - (R** f p alternate ... => continue)))] - - ;; Conditional (pattern changes lost afterwards ...) - [(R** f p [#:when/np test consequent ...] . more) - (let ([continue (lambda (f2) (R** f2 p . more))]) - (if (with-syntax ([p f]) test) - (R** f p consequent ... => continue) - (continue f)))] - - ;; Conditional - [(R** f p [#:when test consequent ...] . more) +(define/contract RSforeach + (->RS/c (->RS/c any/c) (listof any/c)) + (lambda (f xs) + (let loop ([xs xs]) + (if (pair? xs) + (RSseq (lambda () (f (car xs))) + (lambda () (loop (cdr xs)))) + (RSunit (void)))))) + +(define/contract RSadd + (->RS/c (listof protostep?) (->RS/c)) + (lambda (steps a) + (let-values ([(rseq1 final1 exn1) (a)]) + (values (append steps rseq1) final1 exn1)))) + +(define-syntax RS-steps + (syntax-rules () + [(RS-steps expr) + (let-values ([(rseq final exn) expr]) + rseq)])) + +;; CC +;; the context constructor +(define-syntax (CC stx) + (syntax-case stx () + [(CC HOLE expr pattern) + #'(syntax-copier HOLE expr pattern)])) + +;; (R stx R-clause ...) +;; An R-clause is one of +;; [! expr] +;; [#:pattern pattern] +;; [#:bind pattern stx-expr] +;; [#:let-values (var ...) expr] +;; [#:set-syntax stx-expr] +;; [#:walk term2 foci1 foci2 description] +;; [#:walk term2 description] +;; [#:rename form2 foci1 foci2 description] +;; [#:rename/no-step pattern stx stx] +;; [#:reductions expr] +;; [#:learn ids] +;; [#:frontier stxs] +;; [#:when test R-clause ...] +;; [#:if/np test R-clause ...] +;; [generator hole fill] + +;; R +;; the threaded reductions engine + +;; (R form . clauses) : (values (list-of Step) ?stx ?exn) + +(define-syntax R + (syntax-rules () + [(R form . clauses) + (R** #f _ [#:set-syntax form] . clauses)])) + +(define-syntax R** + (syntax-rules (! =>) + ;; Base: done + [(R** form-var pattern) + (RSunit form-var)] + + ;; Base: explicit continuation + [(R** f p => k) + (k f)] + + ;; Error-point case + [(R** f p [! maybe-exn] . more) + (let ([x maybe-exn]) + (unless (or (not x) (exn? x)) + (raise-type-error 'R "exception" x)) + (if x + (values (list (stumble f x)) #f x) + (R** f p . more)))] + + ;; Change patterns + [(R** f p [#:pattern p2] . more) + (R** f p2 . more)] + + ;; Bind pattern variables + [(R** f p [#:bind pattern rhs] . more) + (with-syntax ([pattern (with-syntax ([p f]) rhs)]) + (R** f p . more))] + + ;; Bind variables + [(R** f p [#:let-values (var ...) rhs] . more) + (let-values ([(var ...) (with-syntax ([p f]) rhs)]) + (R** f p . more))] + + ;; Change syntax + [(R** f p [#:set-syntax form] . more) + (let ([form-variable form]) + (R** form-variable p . more))] + + ;; Change syntax and Step (explicit foci) + [(R** f p [#:walk form2 foci1 foci2 description] . more) + (let-values ([(form2-var foci1-var foci2-var description-var) + (with-syntax ([p f]) + (values form2 foci1 foci2 description))]) + (RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var)) + (lambda () (R** form2-var p . more))))] + + ;; Change syntax and Step (infer foci) + [(R** f p [#:walk form2 description] . more) + (let-values ([(form2-var description-var) + (with-syntax ([p f]) + (values form2 description))]) + (RSadd (list (walk f form2-var description-var)) + (lambda () (R** form2-var p . more))))] + + ;; Change syntax with rename + [(R** f p [#:rename form2 foci1 foci2 description] . more) + (let-values ([(form2-var foci1-var foci2-var description-var) + (with-syntax ([p f]) + (values form2 foci1 foci2 description))]) + (rename-frontier f form2-var) + (with-context (make-renames foci1-var foci2-var) + (RSadd (list (walk/foci foci1-var foci2-var + f form2-var + description-var)) + (lambda () (R** form2-var p . more)))))] + + ;; Change syntax with rename (but no step) + [(R** f p [#:rename/no-step pvar from to] . more) + (let-values ([(from-var to-var) + (with-syntax ([p f]) (values from to))]) + (let ([f2 (with-syntax ([p f]) + (with-syntax ([pvar to]) + (syntax p)))]) + (rename-frontier from-var to-var) + (with-context (make-renames from-var to-var) + (R** f2 p . more))))] + + ;; Add in arbitrary other steps + [(R** f p [#:reductions steps] . more) + (RSseq (lambda () steps) + (lambda () (R** f p . more)))] + + ;; Add to definites + [(R** f p [#:learn ids] . more) + (begin (learn-definites (with-syntax ([p f]) ids)) + (R** f p . more))] + + ;; Add to frontier + [(R** f p [#:frontier stxs] . more) + (begin (add-frontier (with-syntax ([p f]) stxs)) + (R** f p . more))] + + ;; Conditional (pattern changes lost afterwards ...) + [(R** f p [#:if/np test [consequent ...] [alternate ...]] . more) + (let ([continue (lambda (f2) (R** f2 p . more))]) (if (with-syntax ([p f]) test) - (R** f p consequent ... . more) - (R** f p . more))] - - ;; Subterm handling - [(R** f p [generator hole fill] . more) - (let ([k (lambda (f2) (R** f2 p . more))]) - (Run f p generator hole fill k))])) + (R** f p consequent ... => continue) + (R** f p alternate ... => continue)))] + + ;; Conditional (pattern changes lost afterwards ...) + [(R** f p [#:when/np test consequent ...] . more) + (let ([continue (lambda (f2) (R** f2 p . more))]) + (if (with-syntax ([p f]) test) + (R** f p consequent ... => continue) + (continue f)))] + + ;; Conditional + [(R** f p [#:when test consequent ...] . more) + (if (with-syntax ([p f]) test) + (R** f p consequent ... . more) + (R** f p . more))] + + ;; Subterm handling + [(R** f p [generator hole fill] . more) + (let ([k (lambda (f2) (R** f2 p . more))]) + (Run f p generator hole fill k))])) - (define-syntax Run - (syntax-rules () - [(Run f p generator hole fill k) - (let ([reducer (with-syntax ([p f]) (generator))]) - (Run* reducer f p hole fill k))])) - - (define-syntax (Run* stx) - (syntax-case stx () - ;; Implementation of subterm handling for (hole ...) sequences - [(Run* f form-var pattern (hole :::) fills k) - (and (identifier? #':::) - (module-identifier=? #'::: (quote-syntax ...))) - #'(let ([ctx (CC (hole :::) form-var pattern)]) - (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))]) - (run-multiple f ctx fills e1s k)))] - ;; Implementation of subterm handling - [(Run* f form-var pattern hole fill k) - #'(let ([ctx (CC hole form-var pattern)]) - (run-one f ctx fill k))])) - - ;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d)) - ;; -> RS(d) - ;; For example: a = Deriv; b = c = d = Syntax - (define (run-multiple f ctx fills suffix k) - (let loop ([fills fills] [prefix null] [suffix suffix]) - (cond - [(pair? fills) - (RSbind (lambda () - (with-context ctx - (with-context (lambda (x) (revappend prefix (cons x (cdr suffix)))) - (f (car fills))))) - (lambda (final) - (loop (cdr fills) - (cons final prefix) - (cdr suffix))))] - [(null? fills) - (let ([form (ctx (reverse prefix))]) - (k form))]))) - - ;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d) - (define (run-one f ctx fill k) - (RSbind (lambda () (with-context ctx (f fill))) - (lambda (final) - (k (ctx final))))) - - ;; Rename mapping +(define-syntax Run + (syntax-rules () + [(Run f p generator hole fill k) + (let ([reducer (with-syntax ([p f]) (generator))]) + (Run* reducer f p hole fill k))])) - (define (rename-frontier from to) - (current-frontier - (with-handlers ([exn:fail? (lambda _ #f)]) - (apply append - (map (make-rename-mapping from to) - (current-frontier)))))) - - (define (make-rename-mapping from0 to0) - (define table (make-hash-table)) - (let loop ([from from0] [to to0]) - (cond [(syntax? from) - (hash-table-put! table from (flatten-syntaxes to)) - (loop (syntax-e from) to)] - [(syntax? to) - (loop from (syntax-e to))] - [(pair? from) - #;(unless (pair? to) - (fprintf (current-error-port) - "from:\n~s\n\n" (syntax-object->datum from0)) - (fprintf (current-error-port) - "to:\n~s\n\n" (syntax-object->datum to0)) - (error 'frontier-renaming)) - (loop (car from) (car to)) - (loop (cdr from) (cdr to))] - [(vector? from) - (loop (vector->list from) (vector->list to))] - [(box? from) - (loop (unbox from) (unbox to))] - [else (void)])) - (lambda (stx) - (let ([replacement (hash-table-get table stx #f)]) - (if replacement - (begin #;(printf " replacing ~s with ~s~n" stx replacement) - replacement) - (begin #;(printf " not replacing ~s~n" stx) - (list stx)))))) +(define-syntax (Run* stx) + (syntax-case stx () + ;; Implementation of subterm handling for (hole ...) sequences + [(Run* f form-var pattern (hole :::) fills k) + (and (identifier? #':::) + (free-identifier=? #'::: (quote-syntax ...))) + #'(let ([ctx (CC (hole :::) form-var pattern)]) + (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))]) + (run-multiple f ctx fills e1s k)))] + ;; Implementation of subterm handling + [(Run* f form-var pattern hole fill k) + #'(let ([ctx (CC hole form-var pattern)]) + (run-one f ctx fill k))])) - (define (flatten-syntaxes x) - (cond [(syntax? x) - (list x)] - [(pair? x) - (append (flatten-syntaxes (car x)) - (flatten-syntaxes (cdr x)))] - [(vector? x) - (flatten-syntaxes (vector->list x))] - [(box? x) - (flatten-syntaxes (unbox x))] - [else null])) +;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d)) +;; -> RS(d) +;; For example: a = Deriv; b = c = d = Syntax +(define (run-multiple f ctx fills suffix k) + (let loop ([fills fills] [prefix null] [suffix suffix]) + (cond + [(pair? fills) + (RSbind (lambda () + (with-context ctx + (with-context (lambda (x) (revappend prefix (cons x (cdr suffix)))) + (f (car fills))))) + (lambda (final) + (loop (cdr fills) + (cons final prefix) + (cdr suffix))))] + [(null? fills) + (let ([form (ctx (reverse prefix))]) + (k form))]))) - ;; ----------------------------------- +;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d) +(define (run-one f ctx fill k) + (RSbind (lambda () (with-context ctx (f fill))) + (lambda (final) + (k (ctx final))))) - ;; walk : syntax(es) syntax(es) StepType -> Reduction - ;; Lifts a local step into a term step. - (define (walk e1 e2 type) - (make-step (current-derivation) (big-context) type (context) - (current-definites) (get-frontier) - (foci e1) (foci e2) e1 e2)) - - ;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction - (define (walk/foci foci1 foci2 Ee1 Ee2 type) - (make-step (current-derivation) (big-context) type (context) - (current-definites) (get-frontier) - (foci foci1) (foci foci2) Ee1 Ee2)) +;; Rename mapping - ;; walk/mono : syntax StepType -> Reduction - (define (walk/mono e1 type) - (make-mono (current-derivation) (big-context) type (context) - (current-definites) (get-frontier) - (foci e1) e1)) - - ;; stumble : syntax exception -> Reduction - (define (stumble stx exn) - (make-misstep (current-derivation) (big-context) 'error (context) - (current-definites) (get-frontier) - (foci stx) stx exn)) - - ;; stumble/E : syntax(s) syntax exn -> Reduction - (define (stumble/E focus Ee1 exn) - (make-misstep (current-derivation) (big-context) 'error (context) - (current-definites) (get-frontier) - (foci focus) Ee1 exn)) - - ;; ------------------------------------ - - (define (revappend a b) - (cond [(pair? a) (revappend (cdr a) (cons (car a) b))] - [(null? a) b])) +(define (rename-frontier from to) + (current-frontier + (with-handlers ([exn:fail? (lambda _ #f)]) + (apply append + (map (make-rename-mapping from to) + (current-frontier)))))) - (define (foci x) - (if (list? x) - x - (list x))) - ) +(define (make-rename-mapping from0 to0) + (define table (make-hash-table)) + (let loop ([from from0] [to to0]) + (cond [(syntax? from) + (hash-table-put! table from (flatten-syntaxes to)) + (loop (syntax-e from) to)] + [(syntax? to) + (loop from (syntax-e to))] + [(pair? from) + #;(unless (pair? to) + (fprintf (current-error-port) + "from:\n~s\n\n" (syntax->datum from0)) + (fprintf (current-error-port) + "to:\n~s\n\n" (syntax->datum to0)) + (error 'frontier-renaming)) + (loop (car from) (car to)) + (loop (cdr from) (cdr to))] + [(vector? from) + (loop (vector->list from) (vector->list to))] + [(box? from) + (loop (unbox from) (unbox to))] + [else (void)])) + (lambda (stx) + (let ([replacement (hash-table-get table stx #f)]) + (if replacement + (begin #;(printf " replacing ~s with ~s~n" stx replacement) + replacement) + (begin #;(printf " not replacing ~s~n" stx) + (list stx)))))) + +(define (flatten-syntaxes x) + (cond [(syntax? x) + (list x)] + [(pair? x) + (append (flatten-syntaxes (car x)) + (flatten-syntaxes (cdr x)))] + [(vector? x) + (flatten-syntaxes (vector->list x))] + [(box? x) + (flatten-syntaxes (unbox x))] + [else null])) + +;; ----------------------------------- + +;; walk : syntax(es) syntax(es) StepType -> Reduction +;; Lifts a local step into a term step. +(define (walk e1 e2 type) + (make-step (current-derivation) (big-context) type (context) + (current-definites) (get-frontier) + (foci e1) (foci e2) e1 e2)) + +;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction +(define (walk/foci foci1 foci2 Ee1 Ee2 type) + (make-step (current-derivation) (big-context) type (context) + (current-definites) (get-frontier) + (foci foci1) (foci foci2) Ee1 Ee2)) + +;; walk/mono : syntax StepType -> Reduction +(define (walk/mono e1 type) + (make-mono (current-derivation) (big-context) type (context) + (current-definites) (get-frontier) + (foci e1) e1)) + +;; stumble : syntax exception -> Reduction +(define (stumble stx exn) + (make-misstep (current-derivation) (big-context) 'error (context) + (current-definites) (get-frontier) + (foci stx) stx exn)) + +;; stumble/E : syntax(s) syntax exn -> Reduction +(define (stumble/E focus Ee1 exn) + (make-misstep (current-derivation) (big-context) 'error (context) + (current-definites) (get-frontier) + (foci focus) Ee1 exn)) + +;; ------------------------------------ + +(define (revappend a b) + (cond [(pair? a) (revappend (cdr a) (cons (car a) b))] + [(null? a) b])) + +(define (foci x) + (if (list? x) + x + (list x))) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index f358e31..56cd7ba 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -1,564 +1,562 @@ -(module reductions mzscheme - (require (lib "plt-match.ss") - "stx-util.ss" - "deriv-util.ss" - "context.ss" - "deriv.ss" - "reductions-engine.ss") +#lang scheme/base +(require scheme/match + "stx-util.ss" + "deriv-util.ss" + "context.ss" + "deriv.ss" + "reductions-engine.ss") - (provide reductions - reductions+) +(provide reductions + reductions+) - ;; Setup for reduction-engines +;; Setup for reduction-engines - (define (Expr) reductions*) - (define (List) list-reductions) - (define (Block) block-reductions) - (define (Transformation) - transformation-reductions) - (define (BindSyntaxes) - bind-syntaxes-reductions) - (define ((CaseLambdaClauses e1)) - (mk-case-lambda-clauses-reductions e1)) - (define ((SynthItems e1)) - (mk-synth-items-reductions e1)) - (define ((BRules es1)) - (mk-brules-reductions es1)) - (define ((ModulePass es1)) - (mk-mbrules-reductions es1)) - - ;; Syntax - - (define-syntax match/with-derivation - (syntax-rules () - [(match/with-derivation d . clauses) - (let ([dvar d]) - (with-derivation dvar - (match dvar . clauses)))])) - - ;; Reductions - - ;; reductions : WDeriv -> ReductionSequence - (define (reductions d) - (parameterize ((current-definites null) - (current-frontier null)) - (when d (add-frontier (list (wderiv-e1 d)))) - (RS-steps (reductions* d)))) +(define (Expr) reductions*) +(define (List) list-reductions) +(define (Block) block-reductions) +(define (Transformation) + transformation-reductions) +(define (BindSyntaxes) + bind-syntaxes-reductions) +(define ((CaseLambdaClauses e1)) + (mk-case-lambda-clauses-reductions e1)) +(define ((SynthItems e1)) + (mk-synth-items-reductions e1)) +(define ((BRules es1)) + (mk-brules-reductions es1)) +(define ((ModulePass es1)) + (mk-mbrules-reductions es1)) - ;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn - (define (reductions+ d) - (parameterize ((current-definites null) - (current-frontier null)) - (when d (add-frontier (list (wderiv-e1 d)))) - (let-values ([(rs stx exn) (reductions* d)]) - (values rs (current-definites) stx exn)))) +;; Syntax - ;; reductions* : WDeriv -> RS(stx) - (define (reductions* d) - (match d - [(Wrap deriv (e1 e2)) - (blaze-frontier e1)] - [_ (void)]) - (match d - [(Wrap prule (e1 e2 rs ?1)) - (and rs (learn-definites rs))] - [_ (void)]) - (match/with-derivation d - ;; Primitives - [(Wrap p:variable (e1 e2 rs ?1)) - (R e1 - [#:learn (list e2)] - [#:when/np (not (bound-identifier=? e1 e2)) - [#:walk e2 e1 e2 'resolve-variable]])] - [(Wrap p:module (e1 e2 rs ?1 #f #f #f body)) - (R e1 - [! ?1] - [#:pattern (?module ?name ?language . ?_body)] - [#:walk (d->so e1 `(,#'?module ,#'?name ,#'?language ,(wderiv-e1 body))) - 'tag-module-begin] - [#:pattern (?module ?name ?language ?body)] - [#:frontier (list #'?body)] - [Expr ?body body])] - [(Wrap p:module (e1 e2 rs ?1 #t mb ?2 body)) - (R e1 - [! ?1] - [#:pattern (?module ?name ?language ?body)] - [#:frontier (list #'?body)] - [Expr ?body mb] - [! ?2] - [#:when/np (not (eq? (wderiv-e2 mb) (wderiv-e1 body))) - [#:walk - (d->so e1 `(,#'?module ,#'?name ,#'?language - ,(wderiv-e1 body))) - 'tag-module-begin]] - [Expr ?body body])] - [(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2)) - (R e1 - [! ?1] - [#:pattern (?module-begin . ?forms)] - [#:frontier (stx->list* #'?forms)] - [(ModulePass #'?forms) - ?forms pass1] - [(ModulePass #'?forms) - ?forms pass2] - [! ?1])] - [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2)) - (R e1 - [! ?1] - [#:pattern (?define-syntaxes formals ?rhs)] - [#:frontier (list #'?rhs)] - [Expr ?rhs rhs] - [! ?2])] - [(Wrap p:define-values (e1 e2 rs ?1 rhs)) - (R e1 - [! ?1] - [#:pattern (?define-values ?formals ?rhs)] - [#:frontier (list #'?rhs)] - ;; RHS can be #f (eg, modprim) - [#:when/np rhs - [Expr ?rhs rhs]])] - [(Wrap p:#%expression (e1 e2 rs ?1 inner)) - (R e1 - [! ?1] - [#:pattern (?expr ?inner)] - [#:frontier (list #'?inner)] - [Expr ?inner inner])] - [(Wrap p:if (e1 e2 rs ?1 full? test then else)) - (if full? - (R e1 - [! ?1] - [#:pattern (?if TEST THEN ELSE)] - [#:frontier (list #'TEST #'THEN #'ELSE)] - [Expr TEST test] - [Expr THEN then] - [Expr ELSE else]) - (R e1 - [! ?1] - [#:pattern (?if TEST THEN)] - [#:frontier (list #'TEST #'THEN)] - [Expr TEST test] - [Expr THEN then]))] - [(Wrap p:wcm (e1 e2 rs ?1 key mark body)) - (R e1 - [! ?1] - [#:pattern (?wcm KEY MARK BODY)] - [#:frontier (list #'KEY #'MARK #'BODY)] - [Expr KEY key] - [Expr MARK mark] - [Expr BODY body])] - [(Wrap p:begin (e1 e2 rs ?1 lderiv)) - (R e1 - [! ?1] - [#:pattern (?begin . ?lderiv)] - [#:frontier (stx->list* #'?lderiv)] - [List ?lderiv lderiv])] - [(Wrap p:begin0 (e1 e2 rs ?1 first lderiv)) - (R e1 - [! ?1] - [#:pattern (?begin0 FIRST . LDERIV)] - [#:frontier (cons #'FIRST (stx->list* #'LDERIV))] - [Expr FIRST first] - [List LDERIV lderiv])] - [(Wrap p:#%app (e1 e2 rs ?1 tagged-stx lderiv)) - (R e1 - [! ?1] - [#:when/np (not (eq? tagged-stx e1)) - [#:walk tagged-stx 'tag-app]] - [#:pattern (?app . LDERIV)] - [#:frontier (stx->list* #'LDERIV)] - [List LDERIV lderiv])] - [(Wrap p:lambda (e1 e2 rs ?1 renames body)) - (R e1 - [! ?1] - [#:bind (?formals* . ?body*) renames] - [#:pattern (?lambda ?formals . ?body)] - [#:frontier (stx->list* #'?body)] - [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) - #'?formals #'?formals* - 'rename-lambda] - [Block ?body body])] - [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) - (R e1 - [! ?1] - [#:pattern (?case-lambda . ?clauses)] - [#:frontier (stx->list* #'?clauses)] - [(CaseLambdaClauses (stx->list* #'?clauses)) - ?clauses clauses])] - [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body)) - (R e1 - [! ?1] - [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] - [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] - [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] - [#:rename - (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) - (syntax->list #'(?vars ...)) - (syntax->list #'(?vars* ...)) - 'rename-let-values] - [Expr (?rhs ...) rhss] - [Block ?body body])] - [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) - (R e1 - [! ?1] - [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] - [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] - [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] - [#:rename - (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) - (syntax->list #'(?vars ...)) - (syntax->list #'(?vars* ...)) - 'rename-letrec-values] - [Expr (?rhs ...) rhss] - [Block ?body body])] - [(Wrap p:letrec-syntaxes+values - (e1 e2 rs ?1 srenames srhss vrenames vrhss body)) - (R e1 - [! ?1] - [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] - [#:frontier (append (syntax->list #'(?srhs ...)) - (syntax->list #'(?vrhs ...)) - (stx->list* #'?body))] - [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames] - [#:rename - (syntax/skeleton e1 - (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) - . ?body*)) - (syntax->list #'(?svars ...)) - (syntax->list #'(?svars* ...)) - 'rename-lsv] - [BindSyntaxes (?srhs ...) srhss] - ;; If vrenames is #f, no var bindings to rename - [#:when/np vrenames - [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] - [#:rename - (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) - ([?vvars** ?vrhs**] ...) - . ?body**)) - (syntax->list #'(?vvars* ...)) - (syntax->list #'(?vvars** ...)) - 'rename-lsv]] - [Expr (?vrhs ...) vrhss] - [Block ?body body] - [#:pattern ?form] - [#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison? - [#:walk e2 'lsv-remove-syntax]])] - ;; The auto-tagged atomic primitives - [(Wrap p:#%datum (e1 e2 rs ?1 tagged-stx)) - (R e1 - [#:when/np (not (eq? e1 tagged-stx)) - [#:walk tagged-stx 'tag-datum]] - [! ?1])] - [(Wrap p:#%top (e1 e2 rs ?1 tagged-stx)) - (R e1 - [#:when/np (not (eq? e1 tagged-stx)) - [#:walk tagged-stx 'tag-top]] - [#:pattern (?top . ?var)] - [#:learn (list #'?var)] - [! ?1])] - - ;; The rest of the automatic primitives - [(Wrap p::STOP (e1 e2 rs ?1)) - (R e1 - [! ?1])] - - [(Wrap p:set!-macro (e1 e2 rs ?1 deriv)) - (R e1 - [! ?1] - [#:frontier (list e1)] - [#:pattern ?form] - [Expr ?form deriv])] - [(Wrap p:set! (e1 e2 rs ?1 id-rs rhs)) - (R e1 - [! ?1] - [#:pattern (?set! ?var ?rhs)] - [#:frontier (list #'?rhs)] - [#:learn id-rs] - [Expr ?rhs rhs])] - - ;; Synthetic primitives - ;; These have their own subterm replacement mechanisms - [(Wrap p:synth (e1 e2 rs ?1 subterms ?2)) - (R e1 - [! ?1] - [#:pattern ?form] - [#:frontier - ;; Compute the frontier based on the expanded subterms - ;; Run through the renames in reverse order to get the - ;; pre-renamed terms - (parameterize ((current-frontier null)) - (let loop ([subterms subterms]) - (cond [(null? subterms) - (void)] - [(s:subterm? (car subterms)) - (loop (cdr subterms)) - (add-frontier - (list (wderiv-e1 (s:subterm-deriv (car subterms)))))] - [(s:rename? (car subterms)) - (loop (cdr subterms)) - (rename-frontier (s:rename-after (car subterms)) - (s:rename-before (car subterms)))])) - (current-frontier))] - [(SynthItems e1) ?form subterms] - [! ?2])] +(define-syntax match/with-derivation + (syntax-rules () + [(match/with-derivation d . clauses) + (let ([dvar d]) + (with-derivation dvar + (match dvar . clauses)))])) - ;; FIXME: elimiate => ?? - [(Wrap p:rename (e1 e2 rs ?1 rename inner)) - (R e1 - [! ?1] - => - (lambda (e) - (rename-frontier (car rename) (cdr rename)) - (reductions* inner)))] - - ;; Macros - [(Wrap mrule (e1 e2 transformation next)) - (R e1 - [#:pattern ?form] - [Transformation ?form transformation] - [#:frontier (list (wderiv-e1 next))] - [Expr ?form next])] - - ;; Lifts - - [(Wrap lift-deriv (e1 e2 first lifted-stx second)) - (R e1 - [#:pattern ?form] - [Expr ?form first] - [#:frontier (list lifted-stx)] - [#:walk lifted-stx 'capture-lifts] - [Expr ?form second])] - - [(Wrap lift/let-deriv (e1 e2 first lifted-stx second)) - (R e1 - [#:pattern ?form] - [Expr ?form first] - [#:frontier (list lifted-stx)] - [#:walk lifted-stx 'capture-lifts] - [Expr ?form second])] - - ;; Skipped - [#f (RSzero)])) - - ;; mk-case-lambda-clauses-reductions : stxs -> - ;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs) - (define ((mk-case-lambda-clauses-reductions es1) clauses) - (blaze-frontier es1) - (match clauses - ['() - (RSunit null)] - [(cons (Wrap clc (?1 rename body)) rest) - (R es1 - [! ?1] - [#:pattern ((?formals . ?body) . ?rest)] - [#:frontier (list #'?body #'?rest)] - [#:bind (?formals* . ?body*) rename] - [#:rename (syntax/skeleton es1 ((?formals* . ?body*) . ?rest)) - #'?formals #'?formals* - 'rename-case-lambda] - [Block ?body body] - [(CaseLambdaClauses (cdr es1)) - ?rest rest])])) - - ;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax) - (define ((mk-synth-items-reductions e1) subterms) - (let loop ([term e1] [subterms subterms]) - (cond [(null? subterms) - (RSunit e1)] - [(s:subterm? (car subterms)) - (let* ([subterm0 (car subterms)] - [path0 (s:subterm-path subterm0)] - [deriv0 (s:subterm-deriv subterm0)]) - (let ([ctx (lambda (x) (path-replace term path0 x))]) - (RSseq (lambda () - (with-context ctx (reductions* deriv0))) - (lambda () - (loop (path-replace term path0 (wderiv-e2 deriv0)) - (cdr subterms))))))] - [(s:rename? (car subterms)) - (let* ([subterm0 (car subterms)]) - ;; FIXME: add renaming steps? - ;; FIXME: if so, coalesce? - (rename-frontier (s:rename-before subterm0) - (s:rename-after subterm0)) - (loop (path-replace term - (s:rename-path subterm0) - (s:rename-after subterm0)) - (cdr subterms)))]))) +;; Reductions - ;; transformation-reductions : Transformation -> (RS Stx) - (define (transformation-reductions tx) - (match tx - [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq)) - (R e1 - [! ?1] - [#:pattern ?form] - [#:learn rs] - [#:reductions (reductions-locals e1 locals)] - [! ?2] - [#:walk e2 - (list #'?form) - (list e2) - 'macro])])) +;; reductions : WDeriv -> ReductionSequence +(define (reductions d) + (parameterize ((current-definites null) + (current-frontier null)) + (when d (add-frontier (list (wderiv-e1 d)))) + (RS-steps (reductions* d)))) - ;; reductions-locals : syntax (list-of LocalAction) -> (RS void) - (define (reductions-locals stx locals) - (with-new-local-context stx - (RSforeach reductions-local locals))) - - ;; reductions-local : LocalAction -> (RS void) - (define (reductions-local local) - (match/with-derivation local - [(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) - (reductions* deriv)] - [(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv)) - (fprintf (current-error-port) - "reductions: local-expand-expr not fully implemented") - (reductions* deriv)] - [(struct local-lift (expr id)) - (RSadd (list (walk expr id 'local-lift)) - RSzero)] - [(struct local-lift-end (decl)) - (RSadd (list (walk/mono decl 'module-lift)) - RSzero)] - [(struct local-bind (bindrhs)) - (bind-syntaxes-reductions bindrhs)])) +;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn +(define (reductions+ d) + (parameterize ((current-definites null) + (current-frontier null)) + (when d (add-frontier (list (wderiv-e1 d)))) + (let-values ([(rs stx exn) (reductions* d)]) + (values rs (current-definites) stx exn)))) - ;; list-reductions : ListDerivation -> (RS Stxs) - (define (list-reductions ld) - (match/with-derivation ld - [(Wrap lderiv (es1 es2 ?1 derivs)) - (R es1 - [! ?1] - [#:pattern (?form ...)] - [Expr (?form ...) derivs])] - [#f (RSunit null)])) - - ;; block-reductions : BlockDerivation -> (RS Stxs) - (define (block-reductions bd) - (match/with-derivation bd - [(Wrap bderiv (es1 es2 pass1 trans pass2)) - (R es1 - [#:pattern ?form] - [(BRules es1) ?form pass1] - [#:when/np (eq? trans 'letrec) - [#:walk (wlderiv-es1 pass2) 'block->letrec]] - [#:frontier (stx->list* (wlderiv-es1 pass2))] - [#:pattern ?form] - [List ?form pass2])] - [#f (RSunit null)])) - - ;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs) - (define ((mk-brules-reductions es1) brules) - (match brules - ['() - (RSunit null)] - [(cons (Wrap b:expr (renames head)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [#:bind ?first* (cdr renames)] - [#:rename/no-step ?first (car renames) (cdr renames)] - [Expr ?first head] - [(BRules (stx-cdr es1)) ?rest rest])] - [(cons (Wrap b:defvals (renames head ?1)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [#:bind ?first* (cdr renames)] - [#:rename/no-step ?first (car renames) (cdr renames)] - [Expr ?first head] - [! ?1] - [#:pattern ((?define-values ?vars ?rhs) . ?rest)] - [#:learn (syntax->list #'?vars)] - [(BRules (stx-cdr es1)) ?rest rest])] - [(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [#:bind ?first* (cdr renames)] - [#:rename/no-step ?first (car renames) (cdr renames)] - [Expr ?first head] - [! ?1] - [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] - [#:learn (syntax->list #'?vars)] - [BindSyntaxes ?rhs bindrhs] - [(BRules (stx-cdr es1)) ?rest rest])] - [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [#:bind ?first* (cdr renames)] - [#:rename/no-step ?first (car renames) (cdr renames)] - [Expr ?first head] - [! ?1] - [#:walk tail - (list #'?first) - (stx-take tail (- (stx-improper-length tail) - (stx-improper-length #'?rest))) - 'splice-block] - [! ?2] - [#:pattern ?forms] - [(BRules (stx->list* #'?forms)) ?forms rest])] - [(cons (Wrap b:error (exn)) rest) - (R es1 - [! exn])])) +;; reductions* : WDeriv -> RS(stx) +(define (reductions* d) + (match d + [(Wrap deriv (e1 e2)) + (blaze-frontier e1)] + [_ (void)]) + (match d + [(Wrap prule (e1 e2 rs ?1)) + (and rs (learn-definites rs))] + [_ (void)]) + (match/with-derivation d + ;; Primitives + [(Wrap p:variable (e1 e2 rs ?1)) + (R e1 + [#:learn (list e2)] + [#:when/np (not (bound-identifier=? e1 e2)) + [#:walk e2 e1 e2 'resolve-variable]])] + [(Wrap p:module (e1 e2 rs ?1 #f #f #f body)) + (R e1 + [! ?1] + [#:pattern (?module ?name ?language . ?_body)] + [#:walk (d->so e1 `(,#'?module ,#'?name ,#'?language ,(wderiv-e1 body))) + 'tag-module-begin] + [#:pattern (?module ?name ?language ?body)] + [#:frontier (list #'?body)] + [Expr ?body body])] + [(Wrap p:module (e1 e2 rs ?1 #t mb ?2 body)) + (R e1 + [! ?1] + [#:pattern (?module ?name ?language ?body)] + [#:frontier (list #'?body)] + [Expr ?body mb] + [! ?2] + [#:when/np (not (eq? (wderiv-e2 mb) (wderiv-e1 body))) + [#:walk + (d->so e1 `(,#'?module ,#'?name ,#'?language + ,(wderiv-e1 body))) + 'tag-module-begin]] + [Expr ?body body])] + [(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2)) + (R e1 + [! ?1] + [#:pattern (?module-begin . ?forms)] + [#:frontier (stx->list* #'?forms)] + [(ModulePass #'?forms) + ?forms pass1] + [(ModulePass #'?forms) + ?forms pass2] + [! ?1])] + [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2)) + (R e1 + [! ?1] + [#:pattern (?define-syntaxes formals ?rhs)] + [#:frontier (list #'?rhs)] + [Expr ?rhs rhs] + [! ?2])] + [(Wrap p:define-values (e1 e2 rs ?1 rhs)) + (R e1 + [! ?1] + [#:pattern (?define-values ?formals ?rhs)] + [#:frontier (list #'?rhs)] + ;; RHS can be #f (eg, modprim) + [#:when/np rhs + [Expr ?rhs rhs]])] + [(Wrap p:#%expression (e1 e2 rs ?1 inner)) + (R e1 + [! ?1] + [#:pattern (?expr ?inner)] + [#:frontier (list #'?inner)] + [Expr ?inner inner])] + [(Wrap p:if (e1 e2 rs ?1 full? test then else)) + (if full? + (R e1 + [! ?1] + [#:pattern (?if TEST THEN ELSE)] + [#:frontier (list #'TEST #'THEN #'ELSE)] + [Expr TEST test] + [Expr THEN then] + [Expr ELSE else]) + (R e1 + [! ?1] + [#:pattern (?if TEST THEN)] + [#:frontier (list #'TEST #'THEN)] + [Expr TEST test] + [Expr THEN then]))] + [(Wrap p:wcm (e1 e2 rs ?1 key mark body)) + (R e1 + [! ?1] + [#:pattern (?wcm KEY MARK BODY)] + [#:frontier (list #'KEY #'MARK #'BODY)] + [Expr KEY key] + [Expr MARK mark] + [Expr BODY body])] + [(Wrap p:begin (e1 e2 rs ?1 lderiv)) + (R e1 + [! ?1] + [#:pattern (?begin . ?lderiv)] + [#:frontier (stx->list* #'?lderiv)] + [List ?lderiv lderiv])] + [(Wrap p:begin0 (e1 e2 rs ?1 first lderiv)) + (R e1 + [! ?1] + [#:pattern (?begin0 FIRST . LDERIV)] + [#:frontier (cons #'FIRST (stx->list* #'LDERIV))] + [Expr FIRST first] + [List LDERIV lderiv])] + [(Wrap p:#%app (e1 e2 rs ?1 tagged-stx lderiv)) + (R e1 + [! ?1] + [#:when/np (not (eq? tagged-stx e1)) + [#:walk tagged-stx 'tag-app]] + [#:pattern (?app . LDERIV)] + [#:frontier (stx->list* #'LDERIV)] + [List LDERIV lderiv])] + [(Wrap p:lambda (e1 e2 rs ?1 renames body)) + (R e1 + [! ?1] + [#:bind (?formals* . ?body*) renames] + [#:pattern (?lambda ?formals . ?body)] + [#:frontier (stx->list* #'?body)] + [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) + #'?formals #'?formals* + 'rename-lambda] + [Block ?body body])] + [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) + (R e1 + [! ?1] + [#:pattern (?case-lambda . ?clauses)] + [#:frontier (stx->list* #'?clauses)] + [(CaseLambdaClauses (stx->list* #'?clauses)) + ?clauses clauses])] + [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body)) + (R e1 + [! ?1] + [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] + [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] + [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] + [#:rename + (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) + (syntax->list #'(?vars ...)) + (syntax->list #'(?vars* ...)) + 'rename-let-values] + [Expr (?rhs ...) rhss] + [Block ?body body])] + [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) + (R e1 + [! ?1] + [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] + [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] + [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] + [#:rename + (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) + (syntax->list #'(?vars ...)) + (syntax->list #'(?vars* ...)) + 'rename-letrec-values] + [Expr (?rhs ...) rhss] + [Block ?body body])] + [(Wrap p:letrec-syntaxes+values + (e1 e2 rs ?1 srenames srhss vrenames vrhss body)) + (R e1 + [! ?1] + [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] + [#:frontier (append (syntax->list #'(?srhs ...)) + (syntax->list #'(?vrhs ...)) + (stx->list* #'?body))] + [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames] + [#:rename + (syntax/skeleton e1 + (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) + . ?body*)) + (syntax->list #'(?svars ...)) + (syntax->list #'(?svars* ...)) + 'rename-lsv] + [BindSyntaxes (?srhs ...) srhss] + ;; If vrenames is #f, no var bindings to rename + [#:when/np vrenames + [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] + [#:rename + (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) + ([?vvars** ?vrhs**] ...) + . ?body**)) + (syntax->list #'(?vvars* ...)) + (syntax->list #'(?vvars** ...)) + 'rename-lsv]] + [Expr (?vrhs ...) vrhss] + [Block ?body body] + [#:pattern ?form] + [#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison? + [#:walk e2 'lsv-remove-syntax]])] + ;; The auto-tagged atomic primitives + [(Wrap p:#%datum (e1 e2 rs ?1 tagged-stx)) + (R e1 + [#:when/np (not (eq? e1 tagged-stx)) + [#:walk tagged-stx 'tag-datum]] + [! ?1])] + [(Wrap p:#%top (e1 e2 rs ?1 tagged-stx)) + (R e1 + [#:when/np (not (eq? e1 tagged-stx)) + [#:walk tagged-stx 'tag-top]] + [#:pattern (?top . ?var)] + [#:learn (list #'?var)] + [! ?1])] + + ;; The rest of the automatic primitives + [(Wrap p::STOP (e1 e2 rs ?1)) + (R e1 + [! ?1])] + + [(Wrap p:set!-macro (e1 e2 rs ?1 deriv)) + (R e1 + [! ?1] + [#:frontier (list e1)] + [#:pattern ?form] + [Expr ?form deriv])] + [(Wrap p:set! (e1 e2 rs ?1 id-rs rhs)) + (R e1 + [! ?1] + [#:pattern (?set! ?var ?rhs)] + [#:frontier (list #'?rhs)] + [#:learn id-rs] + [Expr ?rhs rhs])] + + ;; Synthetic primitives + ;; These have their own subterm replacement mechanisms + [(Wrap p:synth (e1 e2 rs ?1 subterms ?2)) + (R e1 + [! ?1] + [#:pattern ?form] + [#:frontier + ;; Compute the frontier based on the expanded subterms + ;; Run through the renames in reverse order to get the + ;; pre-renamed terms + (parameterize ((current-frontier null)) + (let loop ([subterms subterms]) + (cond [(null? subterms) + (void)] + [(s:subterm? (car subterms)) + (loop (cdr subterms)) + (add-frontier + (list (wderiv-e1 (s:subterm-deriv (car subterms)))))] + [(s:rename? (car subterms)) + (loop (cdr subterms)) + (rename-frontier (s:rename-after (car subterms)) + (s:rename-before (car subterms)))])) + (current-frontier))] + [(SynthItems e1) ?form subterms] + [! ?2])] - ;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx) - (define (bind-syntaxes-reductions bindrhs) - (match bindrhs - [(Wrap bind-syntaxes (rhs ?1)) - (R (wderiv-e1 rhs) - [#:pattern ?form] - [Expr ?form rhs] - [! ?1])])) - - ;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs) - (define ((mk-mbrules-reductions es1) mbrules) - (match mbrules - ['() - (RSunit null)] - [(cons (Wrap mod:skip ()) rest) - (R es1 - [#:pattern (?first . ?rest)] - [(ModulePass (stx-cdr es1)) ?rest rest])] - [(cons (Wrap mod:cons (head)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] - [(ModulePass (stx-cdr es1)) ?rest rest])] - [(cons (Wrap mod:prim (head prim)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] - [Expr ?first prim] - [(ModulePass (stx-cdr es1)) ?rest rest])] - [(cons (Wrap mod:splice (head ?1 tail)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] - [! ?1] - [#:walk tail - (list #'?first) - (stx-take tail (- (stx-improper-length tail) - (stx-improper-length #'?rest))) - 'splice-module] - [#:pattern ?forms] - [(ModulePass #'?forms) ?forms rest])] - [(cons (Wrap mod:lift (head stxs)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] - [#:pattern ?forms] - [#:walk (append stxs #'?forms) - null - stxs - 'splice-lifts] - [(ModulePass #'?forms) ?forms rest])] - [(cons (Wrap mod:lift-end (stxs)) rest) - (R es1 - [#:pattern ?forms] - [#:when/np (pair? stxs) - [#:walk (append stxs #'?forms) - null - stxs - 'splice-module-lifts]] - [(ModulePass #'?forms) ?forms rest])])) - - ) + ;; FIXME: elimiate => ?? + [(Wrap p:rename (e1 e2 rs ?1 rename inner)) + (R e1 + [! ?1] + => + (lambda (e) + (rename-frontier (car rename) (cdr rename)) + (reductions* inner)))] + + ;; Macros + [(Wrap mrule (e1 e2 transformation next)) + (R e1 + [#:pattern ?form] + [Transformation ?form transformation] + [#:frontier (list (wderiv-e1 next))] + [Expr ?form next])] + + ;; Lifts + + [(Wrap lift-deriv (e1 e2 first lifted-stx second)) + (R e1 + [#:pattern ?form] + [Expr ?form first] + [#:frontier (list lifted-stx)] + [#:walk lifted-stx 'capture-lifts] + [Expr ?form second])] + + [(Wrap lift/let-deriv (e1 e2 first lifted-stx second)) + (R e1 + [#:pattern ?form] + [Expr ?form first] + [#:frontier (list lifted-stx)] + [#:walk lifted-stx 'capture-lifts] + [Expr ?form second])] + + ;; Skipped + [#f (RSzero)])) + +;; mk-case-lambda-clauses-reductions : stxs -> +;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs) +(define ((mk-case-lambda-clauses-reductions es1) clauses) + (blaze-frontier es1) + (match clauses + ['() + (RSunit null)] + [(cons (Wrap clc (?1 rename body)) rest) + (R es1 + [! ?1] + [#:pattern ((?formals . ?body) . ?rest)] + [#:frontier (list #'?body #'?rest)] + [#:bind (?formals* . ?body*) rename] + [#:rename (syntax/skeleton es1 ((?formals* . ?body*) . ?rest)) + #'?formals #'?formals* + 'rename-case-lambda] + [Block ?body body] + [(CaseLambdaClauses (cdr es1)) + ?rest rest])])) + +;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax) +(define ((mk-synth-items-reductions e1) subterms) + (let loop ([term e1] [subterms subterms]) + (cond [(null? subterms) + (RSunit e1)] + [(s:subterm? (car subterms)) + (let* ([subterm0 (car subterms)] + [path0 (s:subterm-path subterm0)] + [deriv0 (s:subterm-deriv subterm0)]) + (let ([ctx (lambda (x) (path-replace term path0 x))]) + (RSseq (lambda () + (with-context ctx (reductions* deriv0))) + (lambda () + (loop (path-replace term path0 (wderiv-e2 deriv0)) + (cdr subterms))))))] + [(s:rename? (car subterms)) + (let* ([subterm0 (car subterms)]) + ;; FIXME: add renaming steps? + ;; FIXME: if so, coalesce? + (rename-frontier (s:rename-before subterm0) + (s:rename-after subterm0)) + (loop (path-replace term + (s:rename-path subterm0) + (s:rename-after subterm0)) + (cdr subterms)))]))) + +;; transformation-reductions : Transformation -> (RS Stx) +(define (transformation-reductions tx) + (match tx + [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq)) + (R e1 + [! ?1] + [#:pattern ?form] + [#:learn rs] + [#:reductions (reductions-locals e1 locals)] + [! ?2] + [#:walk e2 + (list #'?form) + (list e2) + 'macro])])) + +;; reductions-locals : syntax (list-of LocalAction) -> (RS void) +(define (reductions-locals stx locals) + (with-new-local-context stx + (RSforeach reductions-local locals))) + +;; reductions-local : LocalAction -> (RS void) +(define (reductions-local local) + (match/with-derivation local + [(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) + (reductions* deriv)] + [(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv)) + (fprintf (current-error-port) + "reductions: local-expand-expr not fully implemented") + (reductions* deriv)] + [(struct local-lift (expr id)) + (RSadd (list (walk expr id 'local-lift)) + RSzero)] + [(struct local-lift-end (decl)) + (RSadd (list (walk/mono decl 'module-lift)) + RSzero)] + [(struct local-bind (bindrhs)) + (bind-syntaxes-reductions bindrhs)])) + +;; list-reductions : ListDerivation -> (RS Stxs) +(define (list-reductions ld) + (match/with-derivation ld + [(Wrap lderiv (es1 es2 ?1 derivs)) + (R es1 + [! ?1] + [#:pattern (?form ...)] + [Expr (?form ...) derivs])] + [#f (RSunit null)])) + +;; block-reductions : BlockDerivation -> (RS Stxs) +(define (block-reductions bd) + (match/with-derivation bd + [(Wrap bderiv (es1 es2 pass1 trans pass2)) + (R es1 + [#:pattern ?form] + [(BRules es1) ?form pass1] + [#:when/np (eq? trans 'letrec) + [#:walk (wlderiv-es1 pass2) 'block->letrec]] + [#:frontier (stx->list* (wlderiv-es1 pass2))] + [#:pattern ?form] + [List ?form pass2])] + [#f (RSunit null)])) + +;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs) +(define ((mk-brules-reductions es1) brules) + (match brules + ['() + (RSunit null)] + [(cons (Wrap b:expr (renames head)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#:rename/no-step ?first (car renames) (cdr renames)] + [Expr ?first head] + [(BRules (stx-cdr es1)) ?rest rest])] + [(cons (Wrap b:defvals (renames head ?1)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#:rename/no-step ?first (car renames) (cdr renames)] + [Expr ?first head] + [! ?1] + [#:pattern ((?define-values ?vars ?rhs) . ?rest)] + [#:learn (syntax->list #'?vars)] + [(BRules (stx-cdr es1)) ?rest rest])] + [(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#:rename/no-step ?first (car renames) (cdr renames)] + [Expr ?first head] + [! ?1] + [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] + [#:learn (syntax->list #'?vars)] + [BindSyntaxes ?rhs bindrhs] + [(BRules (stx-cdr es1)) ?rest rest])] + [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#:rename/no-step ?first (car renames) (cdr renames)] + [Expr ?first head] + [! ?1] + [#:walk tail + (list #'?first) + (stx-take tail (- (stx-improper-length tail) + (stx-improper-length #'?rest))) + 'splice-block] + [! ?2] + [#:pattern ?forms] + [(BRules (stx->list* #'?forms)) ?forms rest])] + [(cons (Wrap b:error (exn)) rest) + (R es1 + [! exn])])) + +;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx) +(define (bind-syntaxes-reductions bindrhs) + (match bindrhs + [(Wrap bind-syntaxes (rhs ?1)) + (R (wderiv-e1 rhs) + [#:pattern ?form] + [Expr ?form rhs] + [! ?1])])) + +;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs) +(define ((mk-mbrules-reductions es1) mbrules) + (match mbrules + ['() + (RSunit null)] + [(cons (Wrap mod:skip ()) rest) + (R es1 + [#:pattern (?first . ?rest)] + [(ModulePass (stx-cdr es1)) ?rest rest])] + [(cons (Wrap mod:cons (head)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [Expr ?first head] + [(ModulePass (stx-cdr es1)) ?rest rest])] + [(cons (Wrap mod:prim (head prim)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [Expr ?first head] + [Expr ?first prim] + [(ModulePass (stx-cdr es1)) ?rest rest])] + [(cons (Wrap mod:splice (head ?1 tail)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [Expr ?first head] + [! ?1] + [#:walk tail + (list #'?first) + (stx-take tail (- (stx-improper-length tail) + (stx-improper-length #'?rest))) + 'splice-module] + [#:pattern ?forms] + [(ModulePass #'?forms) ?forms rest])] + [(cons (Wrap mod:lift (head stxs)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [Expr ?first head] + [#:pattern ?forms] + [#:walk (append stxs #'?forms) + null + stxs + 'splice-lifts] + [(ModulePass #'?forms) ?forms rest])] + [(cons (Wrap mod:lift-end (stxs)) rest) + (R es1 + [#:pattern ?forms] + [#:when/np (pair? stxs) + [#:walk (append stxs #'?forms) + null + stxs + 'splice-module-lifts]] + [(ModulePass #'?forms) ?forms rest])])) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index 64a3b03..f8c6f26 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -1,116 +1,115 @@ -(module steps mzscheme - (require "deriv.ss" - "deriv-util.ss" - "deriv-find.ss") - (provide (all-defined)) +#lang scheme/base +(require "deriv.ss" + "deriv-util.ss" + "deriv-find.ss") +(provide (all-defined-out)) - ;; A ReductionSequence is a (list-of Reduction) +;; A ReductionSequence is a (list-of Reduction) - ;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites) +;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites) - ;; A Context is a list of Frames - ;; A Frame is either: - ;; - (syntax -> syntax) - ;; - (make-renames syntax syntax) - ;; - 'phase-up - (define-struct renames (old new)) +;; A Context is a list of Frames +;; A Frame is either: +;; - (syntax -> syntax) +;; - (make-renames syntax syntax) +;; - 'phase-up +(define-struct renames (old new)) - ;; A Definite is a (list-of identifier) +;; A Definite is a (list-of identifier) - ;; A BigContext is (list-of BigFrame) - ;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax) - (define-struct bigframe (deriv ctx foci e)) +;; A BigContext is (list-of BigFrame) +;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax) +(define-struct bigframe (deriv ctx foci e)) - ;; A Reduction is one of - ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) - ;; - (make-mono ... Syntaxes Syntax) - ;; - (make-misstep ... Syntax Syntax Exception) +;; A Reduction is one of +;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) +;; - (make-mono ... Syntaxes Syntax) +;; - (make-misstep ... Syntax Syntax Exception) - (define-struct protostep (deriv lctx type ctx definites frontier) #f) +(define-struct protostep (deriv lctx type ctx definites frontier) #:transparent) - (define-struct (step protostep) (foci1 foci2 e1 e2) #f) - (define-struct (mono protostep) (foci1 e1) #f) - (define-struct (misstep protostep) (foci1 e1 exn) #f) +(define-struct (step protostep) (foci1 foci2 e1 e2) #:transparent) +(define-struct (mono protostep) (foci1 e1) #:transparent) +(define-struct (misstep protostep) (foci1 e1 exn) #:transparent) - ;; context-fill : Context Syntax -> Syntax - (define (context-fill ctx stx) - (let loop ([ctx ctx] [stx stx]) - (if (null? ctx) - stx - (let ([frame0 (car ctx)]) - (if (procedure? frame0) - (loop (cdr ctx) (frame0 stx)) - (loop (cdr ctx) stx)))))) +;; context-fill : Context Syntax -> Syntax +(define (context-fill ctx stx) + (let loop ([ctx ctx] [stx stx]) + (if (null? ctx) + stx + (let ([frame0 (car ctx)]) + (if (procedure? frame0) + (loop (cdr ctx) (frame0 stx)) + (loop (cdr ctx) stx)))))) - ;; context-env : Context -> (list-of identifier) - (define (context-env ctx) - (let loop ([ctx ctx] [env null]) - (if (null? ctx) - env - (let ([frame0 (car ctx)]) - (if (renames? frame0) - (loop (cdr ctx) - (append (flatten-identifiers (renames-new frame0)) - env)) - (loop (cdr ctx) env)))))) +;; context-env : Context -> (list-of identifier) +(define (context-env ctx) + (let loop ([ctx ctx] [env null]) + (if (null? ctx) + env + (let ([frame0 (car ctx)]) + (if (renames? frame0) + (loop (cdr ctx) + (append (flatten-identifiers (renames-new frame0)) + env)) + (loop (cdr ctx) env)))))) - (define (step-term1 s) - (context-fill (protostep-ctx s) (step-e1 s))) - (define (step-term2 s) - (context-fill (protostep-ctx s) (step-e2 s))) +(define (step-term1 s) + (context-fill (protostep-ctx s) (step-e1 s))) +(define (step-term2 s) + (context-fill (protostep-ctx s) (step-e2 s))) - (define (mono-term1 s) - (context-fill (protostep-ctx s) (mono-e1 s))) +(define (mono-term1 s) + (context-fill (protostep-ctx s) (mono-e1 s))) - (define (misstep-term1 s) - (context-fill (protostep-ctx s) (misstep-e1 s))) +(define (misstep-term1 s) + (context-fill (protostep-ctx s) (misstep-e1 s))) - (define (bigframe-term bf) - (context-fill (bigframe-ctx bf) (bigframe-e bf))) +(define (bigframe-term bf) + (context-fill (bigframe-ctx bf) (bigframe-e bf))) - ;; A StepType is a simple in the following alist. +;; A StepType is a simple in the following alist. - (define step-type-meanings - '((macro . "Macro transformation") - - (rename-lambda . "Rename formal parameters") - (rename-case-lambda . "Rename formal parameters") - (rename-let-values . "Rename bound variables") - (rename-letrec-values . "Rename bound variables") - (rename-lsv . "Rename bound variables") - (lsv-remove-syntax . "Remove syntax bindings") +(define step-type-meanings + '((macro . "Macro transformation") + + (rename-lambda . "Rename formal parameters") + (rename-case-lambda . "Rename formal parameters") + (rename-let-values . "Rename bound variables") + (rename-letrec-values . "Rename bound variables") + (rename-lsv . "Rename bound variables") + (lsv-remove-syntax . "Remove syntax bindings") - (resolve-variable . "Resolve variable (remove extra marks)") - (tag-module-begin . "Tag #%module-begin") - (tag-app . "Tag application") - (tag-datum . "Tag datum") - (tag-top . "Tag top-level variable") - (capture-lifts . "Capture lifts") + (resolve-variable . "Resolve variable (remove extra marks)") + (tag-module-begin . "Tag #%module-begin") + (tag-app . "Tag application") + (tag-datum . "Tag datum") + (tag-top . "Tag top-level variable") + (capture-lifts . "Capture lifts") - (local-lift . "Macro lifted expression to top-level") - (module-lift . "Macro lifted declaration to end of module") - (block->letrec . "Transform block to letrec") - (splice-block . "Splice block-level begin") - (splice-module . "Splice module-level begin") - (splice-lifts . "Splice definitions from lifted expressions") - (splice-module-lifts . "Splice lifted module declarations") + (local-lift . "Macro lifted expression to top-level") + (module-lift . "Macro lifted declaration to end of module") + (block->letrec . "Transform block to letrec") + (splice-block . "Splice block-level begin") + (splice-module . "Splice module-level begin") + (splice-lifts . "Splice definitions from lifted expressions") + (splice-module-lifts . "Splice lifted module declarations") - (error . "Error"))) + (error . "Error"))) - (define (step-type->string x) - (cond [(assq x step-type-meanings) => cdr] - [(string? x) x] - [else (error 'step-type->string "not a step type: ~s" x)])) +(define (step-type->string x) + (cond [(assq x step-type-meanings) => cdr] + [(string? x) x] + [else (error 'step-type->string "not a step type: ~s" x)])) - (define (rename-step? x) - (memq (protostep-type x) - '(rename-lambda - rename-case-lambda - rename-let-values - rename-letrec-values - rename-lsv))) +(define (rename-step? x) + (memq (protostep-type x) + '(rename-lambda + rename-case-lambda + rename-let-values + rename-letrec-values + rename-lsv))) - (define (rewrite-step? x) - (and (step? x) (not (rename-step? x)))) -) +(define (rewrite-step? x) + (and (step? x) (not (rename-step? x)))) diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.ss index 0a62d09..9141bd7 100644 --- a/collects/macro-debugger/model/stx-util.ss +++ b/collects/macro-debugger/model/stx-util.ss @@ -1,100 +1,99 @@ -(module stx-util mzscheme - (require (lib "stx.ss" "syntax")) - - (provide (all-defined) - (all-from (lib "stx.ss" "syntax"))) - - (define (d->so template datum) - (if (syntax? template) - (datum->syntax-object template datum template template) - datum)) - - (define-syntax (syntax-copier stx) - (syntax-case stx () - [(syntax-copier hole expr pattern) - #'(let ([expr-var expr]) - (lambda (in-the-hole) - (with-syntax ([pattern expr-var]) - (with-syntax ([hole in-the-hole]) - (syntax/restamp pattern #'pattern expr-var)))))])) - - (define-syntax syntax/skeleton - (syntax-rules () - [(syntax/skeleton old-expr pattern) - (syntax/restamp pattern #'pattern old-expr)])) - - - ;; FIXME: Need to avoid turning syntax lists into syntax pairs - (define-syntax (syntax/restamp stx) - (syntax-case stx (...) - [(syntax/restamp (pa (... ...)) new-expr old-expr) - #`(let ([new-parts (stx->list new-expr)] - [old-parts (stx->list old-expr)]) - ;; FIXME - (unless (= (length new-parts) (length old-parts)) - (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) - (printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...)))) - (printf "old parts: ~s~n" (map syntax-object->datum old-parts)) - (printf "new parts: ~s~n" (map syntax-object->datum new-parts))) - (d->so - old-expr - (map (lambda (new old) (syntax/restamp pa new old)) - new-parts - old-parts)))] - [(syntax/restamp (pa . pb) new-expr old-expr) - ;; FIXME - #'(begin - (unless (and (stx-pair? new-expr) (stx-pair? old-expr)) - (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) - (printf "pattern : ~s~n" (syntax-object->datum (quote-syntax (pa . pb)))) - (printf "old parts: ~s~n" old-expr) - (printf "new parts: ~s~n" new-expr)) - (let ([na (stx-car new-expr)] - [nb (stx-cdr new-expr)] - [oa (stx-car old-expr)] - [ob (stx-cdr old-expr)]) - (d->so old-expr - (cons (syntax/restamp pa na oa) - (syntax/restamp pb nb ob)))))] - [(syntax/restamp pvar new-expr old-expr) - #'new-expr])) +#lang scheme/base +(require (for-syntax scheme/base) + syntax/stx) - (define (iota n) - (let loop ([i 0]) - (if (< i n) - (cons i (loop (add1 i))) - null))) +(provide (all-defined-out) + (all-from-out syntax/stx)) - ;; stx-take : syntax-list number -> (list-of syntax) - (define (stx-take items n) - (cond [(zero? n) null] - [else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) +(define (d->so template datum) + (if (syntax? template) + (datum->syntax template datum template template) + datum)) - (define (take-if-possible items n) - (unless (number? n) - (raise-type-error 'take-if-possible "number" n)) - (if (and (pair? items) (positive? n)) - (cons (car items) (take-if-possible (cdr items) (sub1 n))) - null)) +(define-syntax (syntax-copier stx) + (syntax-case stx () + [(syntax-copier hole expr pattern) + #'(let ([expr-var expr]) + (lambda (in-the-hole) + (with-syntax ([pattern expr-var]) + (with-syntax ([hole in-the-hole]) + (syntax/restamp pattern #'pattern expr-var)))))])) - ;; stx-improper-length : syntax -> number - (define (stx-improper-length stx) - (let loop ([stx stx] [n 0]) - (if (stx-pair? stx) - (loop (stx-cdr stx) (add1 n)) - n))) +(define-syntax syntax/skeleton + (syntax-rules () + [(syntax/skeleton old-expr pattern) + (syntax/restamp pattern #'pattern old-expr)])) - (define (stx->list* stx) - (cond [(pair? stx) - (cons (car stx) (stx->list* (cdr stx)))] - [(null? stx) - null] - [(syntax? stx) - (let ([x (syntax-e stx)]) - (if (pair? x) - (cons (car x) (stx->list* (cdr x))) - (list stx)))] - [else null])) -) +;; FIXME: Need to avoid turning syntax lists into syntax pairs +(define-syntax (syntax/restamp stx) + (syntax-case stx (...) + [(syntax/restamp (pa (... ...)) new-expr old-expr) + #`(let ([new-parts (stx->list new-expr)] + [old-parts (stx->list old-expr)]) + ;; FIXME + (unless (= (length new-parts) (length old-parts)) + (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) + (printf "pattern : ~s~n" (syntax->datum #'(pa (... ...)))) + (printf "old parts: ~s~n" (map syntax->datum old-parts)) + (printf "new parts: ~s~n" (map syntax->datum new-parts))) + (d->so + old-expr + (map (lambda (new old) (syntax/restamp pa new old)) + new-parts + old-parts)))] + [(syntax/restamp (pa . pb) new-expr old-expr) + ;; FIXME + #'(begin + (unless (and (stx-pair? new-expr) (stx-pair? old-expr)) + (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) + (printf "pattern : ~s~n" (syntax->datum (quote-syntax (pa . pb)))) + (printf "old parts: ~s~n" old-expr) + (printf "new parts: ~s~n" new-expr)) + (let ([na (stx-car new-expr)] + [nb (stx-cdr new-expr)] + [oa (stx-car old-expr)] + [ob (stx-cdr old-expr)]) + (d->so old-expr + (cons (syntax/restamp pa na oa) + (syntax/restamp pb nb ob)))))] + [(syntax/restamp pvar new-expr old-expr) + #'new-expr])) + +(define (iota n) + (let loop ([i 0]) + (if (< i n) + (cons i (loop (add1 i))) + null))) + +;; stx-take : syntax-list number -> (list-of syntax) +(define (stx-take items n) + (cond [(zero? n) null] + [else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) + +(define (take-if-possible items n) + (unless (number? n) + (raise-type-error 'take-if-possible "number" n)) + (if (and (pair? items) (positive? n)) + (cons (car items) (take-if-possible (cdr items) (sub1 n))) + null)) + +;; stx-improper-length : syntax -> number +(define (stx-improper-length stx) + (let loop ([stx stx] [n 0]) + (if (stx-pair? stx) + (loop (stx-cdr stx) (add1 n)) + n))) + +(define (stx->list* stx) + (cond [(pair? stx) + (cons (car stx) (stx->list* (cdr stx)))] + [(null? stx) + null] + [(syntax? stx) + (let ([x (syntax-e stx)]) + (if (pair? x) + (cons (car x) (stx->list* (cdr x))) + (list stx)))] + [else null])) diff --git a/collects/macro-debugger/model/trace-raw.ss b/collects/macro-debugger/model/trace-raw.ss index 3f9c8e9..5fc8702 100644 --- a/collects/macro-debugger/model/trace-raw.ss +++ b/collects/macro-debugger/model/trace-raw.ss @@ -1,37 +1,36 @@ -(module trace-raw mzscheme - (require "../syntax-browser.ss" - (lib "class.ss") - (lib "lex.ss" "parser-tools") - "deriv-tokens.ss" - "deriv-parser.ss") - (provide (all-defined)) +#lang scheme/base +(require scheme/class + parser-tools/lex + "deriv-tokens.ss" + "deriv-parser.ss" + "../syntax-browser.ss") +(provide (all-defined-out)) - (define current-expand-observe - (dynamic-require ''#%expobs 'current-expand-observe)) +(define current-expand-observe + (dynamic-require ''#%expobs 'current-expand-observe)) + +(define (go-trace sexpr) + (define events null) + (define pos 0) + (define browser (make-syntax-browser)) + (define (show sig+val) + (define sig (car sig+val)) + (define val (cdr sig+val)) + (define t (tokenize sig val pos)) + (send browser add-text + (format "Signal: ~s: ~s~n" + pos + (token-name (position-token-token t)))) + (when val + (send browser add-syntax + (datum->syntax #f val))) + (set! pos (add1 pos))) + (parameterize ((current-expand-observe + (lambda (sig val) + (define t (tokenize sig val pos)) + (set! events (cons (cons sig val) events)) + #;(show (cons sig val))))) + (expand sexpr) + (for-each show (reverse events)))) - (define (go-trace sexpr) - (define events null) - (define pos 0) - (define browser (make-syntax-browser)) - (define (show sig+val) - (define sig (car sig+val)) - (define val (cdr sig+val)) - (define t (tokenize sig val pos)) - (send browser add-text - (format "Signal: ~s: ~s~n" - pos - (token-name (position-token-token t)))) - (when val - (send browser add-syntax - (datum->syntax-object #f val))) - (set! pos (add1 pos))) - (parameterize ((current-expand-observe - (lambda (sig val) - (define t (tokenize sig val pos)) - (set! events (cons (cons sig val) events)) - #;(show (cons sig val))))) - (expand sexpr) - (for-each show (reverse events)))) - - ) \ No newline at end of file diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss index 94f06a4..b9339aa 100644 --- a/collects/macro-debugger/model/trace.ss +++ b/collects/macro-debugger/model/trace.ss @@ -1,73 +1,73 @@ -(module trace mzscheme - (require (lib "lex.ss" "parser-tools")) - (require "deriv.ss" - "deriv-parser.ss" - "deriv-tokens.ss") +#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) +(provide trace + trace* + trace/result + trace-verbose? + events->token-generator + current-expand-observe) - (define current-expand-observe - (dynamic-require ''#%expobs 'current-expand-observe)) +(define current-expand-observe + (dynamic-require ''#%expobs 'current-expand-observe)) - (define trace-verbose? (make-parameter #f)) +(define trace-verbose? (make-parameter #f)) - ;; trace : stx -> Deriv - (define (trace stx) - (let-values ([(result events derivp) (trace* stx expand)]) - (force derivp))) +;; trace : stx -> Deriv +(define (trace stx) + (let-values ([(result events derivp) (trace* stx expand)]) + (force derivp))) - ;; trace/result : stx -> stx/exn Deriv - (define (trace/result stx) - (let-values ([(result events derivp) (trace* stx expand)]) - (values result - (force derivp)))) +;; trace/result : stx -> stx/exn Deriv +(define (trace/result stx) + (let-values ([(result events derivp) (trace* stx expand)]) + (values result + (force derivp)))) - ;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv) - (define (trace* stx expander) - (let-values ([(result events) (expand/events stx expander)]) - (values result - events - (delay (parse-derivation - (events->token-generator events)))))) +;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv) +(define (trace* stx expander) + (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 0]) - (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)))) +;; events->token-generator : (list-of event) -> (-> token) +(define (events->token-generator events) + (let ([pos 0]) + (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)))) - ;; expand/events : stx (stx -> stx) -> stx/exn (list-of event) - (define (expand/events sexpr expander) - (let ([events null]) - (define (add! x) - (set! events (cons x events))) - (parameterize ((current-expand-observe - (let ([c 0]) - (lambda (sig val) - (set! c (add1 c)) - (add! (cons sig val)))))) - (let ([result - (with-handlers ([(lambda (exn) #t) - (lambda (exn) - (add! (cons 'error exn)) - exn)]) - (expander sexpr))]) - (add! (cons 'EOF #f)) - (values result - (reverse events)))))) - ) +;; expand/events : stx (stx -> stx) -> stx/exn (list-of event) +(define (expand/events sexpr expander) + (let ([events null]) + (define (add! x) + (set! events (cons x events))) + (parameterize ((current-expand-observe + (let ([c 0]) + (lambda (sig val) + (set! c (add1 c)) + (add! (cons sig val)))))) + (let ([result + (with-handlers ([(lambda (exn) #t) + (lambda (exn) + (add! (cons 'error exn)) + exn)]) + (expander sexpr))]) + (add! (cons 'EOF #f)) + (values result + (reverse events)))))) diff --git a/collects/macro-debugger/model/yacc-ext.ss b/collects/macro-debugger/model/yacc-ext.ss index 9af3f87..85ef44b 100644 --- a/collects/macro-debugger/model/yacc-ext.ss +++ b/collects/macro-debugger/model/yacc-ext.ss @@ -1,50 +1,49 @@ -(module yacc-ext mzscheme - - (require (prefix yacc: (lib "yacc.ss" "parser-tools"))) - (provide parser - options - productions - definitions) - - (define-syntax options - (lambda (stx) - (raise-syntax-error #f "options keyword used out of context" stx))) - - (define-syntax productions - (lambda (stx) - (raise-syntax-error #f "productions keyword used out of context" stx))) +#lang scheme/base +(require (prefix-in yacc: parser-tools/yacc) + (for-syntax scheme/base)) +(provide parser + options + productions + definitions) - (define-syntax definitions - (lambda (stx) - (raise-syntax-error #f "definitions keyword used out of context" stx))) +(define-syntax options + (lambda (stx) + (raise-syntax-error #f "options keyword used out of context" stx))) - (define-syntax (parser stx) - (syntax-case stx () - [(parser form ...) - (let ([stop-list (list #'begin #'options #'productions #'definitions)] - [forms (syntax->list #'(form ...))]) - (define-values (opts prods defs) - (let loop ([forms forms] [opts null] [prods null] [defs null]) - (if (pair? forms) - (let ([eform0 (local-expand (car forms) 'expression stop-list)] - [forms (cdr forms)]) - (syntax-case eform0 (begin options productions definitions) - [(begin subform ...) - (loop (append (syntax->list #'(subform ...)) forms) opts prods defs)] - [(options subform ...) - (loop forms (append (syntax->list #'(subform ...)) opts) prods defs)] - [(productions subform ...) - (loop forms opts (append (syntax->list #'(subform ...)) prods) defs)] - [(definitions subform ...) - (loop forms opts prods (append (syntax->list #'(subform ...)) defs))] - [else - (raise-syntax-error #f "bad parser subform" eform0)])) - (values opts prods defs)))) - (with-syntax ([(opt ...) opts] - [(prod ...) prods] - [(def ...) defs]) - #'(let () - def ... - (#%expression (yacc:parser opt ... (grammar prod ...))))))])) - ) +(define-syntax productions + (lambda (stx) + (raise-syntax-error #f "productions keyword used out of context" stx))) + +(define-syntax definitions + (lambda (stx) + (raise-syntax-error #f "definitions keyword used out of context" stx))) + +(define-syntax (parser stx) + (syntax-case stx () + [(parser form ...) + (let ([stop-list (list #'begin #'options #'productions #'definitions)] + [forms (syntax->list #'(form ...))]) + (define-values (opts prods defs) + (let loop ([forms forms] [opts null] [prods null] [defs null]) + (if (pair? forms) + (let ([eform0 (local-expand (car forms) 'expression stop-list)] + [forms (cdr forms)]) + (syntax-case eform0 (begin options productions definitions) + [(begin subform ...) + (loop (append (syntax->list #'(subform ...)) forms) opts prods defs)] + [(options subform ...) + (loop forms (append (syntax->list #'(subform ...)) opts) prods defs)] + [(productions subform ...) + (loop forms opts (append (syntax->list #'(subform ...)) prods) defs)] + [(definitions subform ...) + (loop forms opts prods (append (syntax->list #'(subform ...)) defs))] + [else + (raise-syntax-error #f "bad parser subform" eform0)])) + (values opts prods defs)))) + (with-syntax ([(opt ...) opts] + [(prod ...) prods] + [(def ...) defs]) + #'(let () + def ... + (#%expression (yacc:parser opt ... (grammar prod ...))))))])) diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.ss index faf8627..4fb494e 100644 --- a/collects/macro-debugger/model/yacc-interrupted.ss +++ b/collects/macro-debugger/model/yacc-interrupted.ss @@ -1,302 +1,302 @@ -(module yacc-interrupted mzscheme - (require-for-syntax (lib "etc.ss")) - (require "yacc-ext.ss") - (provide ! ? !! - define-production-splitter - skipped-token-values - %skipped - %action) +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax mzlib/etc) + "yacc-ext.ss") +(provide ! ? !! + define-production-splitter + skipped-token-values + %skipped + %action) - ;; Grammar macros for "interrupted parses" +;; Grammar macros for "interrupted parses" - (define-syntax ! - (lambda (stx) - (raise-syntax-error #f "keyword ! used out of context" stx))) +(define-syntax ! + (lambda (stx) + (raise-syntax-error #f "keyword ! used out of context" stx))) - (define-syntax !! - (lambda (stx) - (raise-syntax-error #f "keyword !! used out of context" stx))) +(define-syntax !! + (lambda (stx) + (raise-syntax-error #f "keyword !! used out of context" stx))) - (define-syntax ? - (lambda (stx) - (raise-syntax-error #f "keyword ? used out of context" stx))) +(define-syntax ? + (lambda (stx) + (raise-syntax-error #f "keyword ? used out of context" stx))) - (define-syntax define-production-splitter - (syntax-rules () - [(define-production-splitter name ok intW) - (define-syntax name - (make-production-splitter #'ok #'intW))])) +(define-syntax define-production-splitter + (syntax-rules () + [(define-production-splitter name ok intW) + (define-syntax name + (make-production-splitter #'ok #'intW))])) - (define-for-syntax (partition-options/alternates forms) - (let loop ([forms forms] [options null] [alts null]) - (if (pair? forms) - (syntax-case (car forms) () - [(#:args . args) - (loop (cdr forms) (cons (cons #:args #'args) options) alts)] - [(#:skipped expr) - (loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)] - [(#:wrap) - (loop (cdr forms) (cons (cons #:wrap #t) options) alts)] - [(#:no-wrap) - (loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)] - [(kw . args) - (keyword? (syntax-e #'kw)) - (raise-syntax-error 'split "bad keyword" (car forms))] - [(pattern action) - (loop (cdr forms) options (cons (cons #'pattern #'action) alts))] - [other - (raise-syntax-error 'split "bad grammar option or alternate" #'other)]) - (values options (reverse alts))))) +(define-for-syntax (partition-options/alternates forms) + (let loop ([forms forms] [options null] [alts null]) + (if (pair? forms) + (syntax-case (car forms) () + [(#:args . args) + (loop (cdr forms) (cons (cons '#:args #'args) options) alts)] + [(#:skipped expr) + (loop (cdr forms) (cons (cons '#:skipped #'expr) options) alts)] + [(#:wrap) + (loop (cdr forms) (cons (cons '#:wrap #t) options) alts)] + [(#:no-wrap) + (loop (cdr forms) (cons (cons '#:no-wrap #t) options) alts)] + [(kw . args) + (keyword? (syntax-e #'kw)) + (raise-syntax-error 'split "bad keyword" (car forms))] + [(pattern action) + (loop (cdr forms) options (cons (cons #'pattern #'action) alts))] + [other + (raise-syntax-error 'split "bad grammar option or alternate" #'other)]) + (values options (reverse alts))))) - (define-for-syntax (symbol+ . args) - (define (norm x) - (cond [(identifier? x) (norm (syntax-e x))] - [(string? x) x] - [(number? x) (number->string x)] - [(symbol? x) (symbol->string x)])) - (string->symbol (apply string-append (map norm args)))) +(define-for-syntax (symbol+ . args) + (define (norm x) + (cond [(identifier? x) (norm (syntax-e x))] + [(string? x) x] + [(number? x) (number->string x)] + [(symbol? x) (symbol->string x)])) + (string->symbol (apply string-append (map norm args)))) - (define-for-syntax (I symbol) - (syntax-local-introduce - (syntax-local-get-shadower (datum->syntax-object #f symbol)))) +(define-for-syntax (I symbol) + (syntax-local-introduce + (syntax-local-get-shadower (datum->syntax #f symbol)))) - (define-for-syntax ($name n) - (I (symbol+ '$ n))) +(define-for-syntax ($name n) + (I (symbol+ '$ n))) - (define-for-syntax (interrupted-name s) - (I (symbol+ s '/Interrupted))) +(define-for-syntax (interrupted-name s) + (I (symbol+ s '/Interrupted))) - (define-for-syntax (skipped-name s) - (I (symbol+ s '/Skipped))) +(define-for-syntax (skipped-name s) + (I (symbol+ s '/Skipped))) - (define-for-syntax (elaborate-skipped-tail head tail position args mk-action) - (define-values (new-tail new-arguments) - (let loop ([parts tail] [position position] [rtail null] [arguments null]) - (syntax-case parts (? ! !!) - [() - (values (reverse rtail) (reverse arguments))] - [(! . parts-rest) - (loop #'parts-rest position rtail (cons #'#f arguments))] - [(!! . parts-rest) - (raise-syntax-error 'split - "cannot have !! after potential error" - #'!!)] - [((? NT) . parts-rest) - (loop #'(NT . parts-rest) position rtail arguments)] - [(NT . parts-rest) - (identifier? #'NT) - (loop #'parts-rest - (add1 position) - (cons (skipped-name #'NT) rtail) - (cons ($name position) arguments))]))) - (define arguments (append (reverse args) new-arguments)) - (cons #`(#,head . #,new-tail) - (mk-action arguments))) - - (define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt) - (define pattern (car alt)) - (define action-function (cdr alt)) - (define-values (new-patterns arguments) - (let loop ([parts pattern] [rpattern null] [position 1] [args null]) - (syntax-case parts (? ! !!) - [() (values (list (reverse rpattern)) (reverse args))] - [(! . parts-rest) - (loop #'parts-rest rpattern position (cons #'#f args))] - [(!!) - (values null null)] - [((? NT) . parts-rest) - (loop (cons #'NT #'parts-rest) rpattern position args)] - [(NT . parts-rest) - (identifier? #'NT) - (loop #'parts-rest (cons #'NT rpattern) - (add1 position) (cons ($name position) args))]))) - (map (lambda (new-pattern) - (cons (datum->syntax-object #f new-pattern pattern) - #`(#,action-function #,(if wrap? okW #'values) #,@arguments))) - new-patterns)) - - (define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt) - (define pattern (car alt)) - (define action-function (cdr alt)) - (define (int-action args) - (let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)]) - #`(#,action-function #,wrapf #,@args))) - (let loop ([parts pattern] [position 1] [args null]) +(define-for-syntax (elaborate-skipped-tail head tail position args mk-action) + (define-values (new-tail new-arguments) + (let loop ([parts tail] [position position] [rtail null] [arguments null]) (syntax-case parts (? ! !!) [() - ;; Can't be interrupted - null] + (values (reverse rtail) (reverse arguments))] [(! . parts-rest) - (cons - ;; Error occurs - (elaborate-skipped-tail (I 'syntax-error) - #'parts-rest - (add1 position) - (cons ($name position) args) - int-action) - ;; Error doesn't occur - (loop #'parts-rest position (cons #'#f args)))] - [(!!) - (cons - (elaborate-skipped-tail (I 'syntax-error) - #'() - (add1 position) - (cons ($name position) args) - int-action) - null)] + (loop #'parts-rest position rtail (cons #'#f arguments))] + [(!! . parts-rest) + (raise-syntax-error 'split + "cannot have !! after potential error" + #'!!)] [((? NT) . parts-rest) - (cons - ;; NT is interrupted - (elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted)) - #'parts-rest - (add1 position) - (cons ($name position) args) - int-action) - ;; NT is not interrupted - (loop #'(NT . parts-rest) position args))] - [(part0 . parts-rest) - (identifier? #'part0) - (map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause))) - (loop #'parts-rest (add1 position) (cons ($name position) args)))]))) + (loop #'(NT . parts-rest) position rtail arguments)] + [(NT . parts-rest) + (identifier? #'NT) + (loop #'parts-rest + (add1 position) + (cons (skipped-name #'NT) rtail) + (cons ($name position) arguments))]))) + (define arguments (append (reverse args) new-arguments)) + (cons #`(#,head . #,new-tail) + (mk-action arguments))) - (define-for-syntax (generate-action-name nt pos) - (syntax-local-get-shadower - (datum->syntax-object #f (symbol+ 'action-for- nt '/ pos)))) - - (define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos) - (define pattern (car alt)) - (define action (cdr alt)) - (define-values (var-indexes non-var-indexes) - (let loop ([pattern pattern] [n 1] [vars null] [nonvars null]) - (syntax-case pattern () - [(first . more) - (syntax-case #'first (! ? !!) - [! - (loop #'more (add1 n) (cons n vars) nonvars)] - [(! . _) +(define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt) + (define pattern (car alt)) + (define action-function (cdr alt)) + (define-values (new-patterns arguments) + (let loop ([parts pattern] [rpattern null] [position 1] [args null]) + (syntax-case parts (? ! !!) + [() (values (list (reverse rpattern)) (reverse args))] + [(! . parts-rest) + (loop #'parts-rest rpattern position (cons #'#f args))] + [(!!) + (values null null)] + [((? NT) . parts-rest) + (loop (cons #'NT #'parts-rest) rpattern position args)] + [(NT . parts-rest) + (identifier? #'NT) + (loop #'parts-rest (cons #'NT rpattern) + (add1 position) (cons ($name position) args))]))) + (map (lambda (new-pattern) + (cons (datum->syntax #f new-pattern pattern) + #`(#,action-function #,(if wrap? okW #'values) #,@arguments))) + new-patterns)) + +(define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt) + (define pattern (car alt)) + (define action-function (cdr alt)) + (define (int-action args) + (let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)]) + #`(#,action-function #,wrapf #,@args))) + (let loop ([parts pattern] [position 1] [args null]) + (syntax-case parts (? ! !!) + [() + ;; Can't be interrupted + null] + [(! . parts-rest) + (cons + ;; Error occurs + (elaborate-skipped-tail (I 'syntax-error) + #'parts-rest + (add1 position) + (cons ($name position) args) + int-action) + ;; Error doesn't occur + (loop #'parts-rest position (cons #'#f args)))] + [(!!) + (cons + (elaborate-skipped-tail (I 'syntax-error) + #'() + (add1 position) + (cons ($name position) args) + int-action) + null)] + [((? NT) . parts-rest) + (cons + ;; NT is interrupted + (elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted)) + #'parts-rest + (add1 position) + (cons ($name position) args) + int-action) + ;; NT is not interrupted + (loop #'(NT . parts-rest) position args))] + [(part0 . parts-rest) + (identifier? #'part0) + (map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause))) + (loop #'parts-rest (add1 position) (cons ($name position) args)))]))) + +(define-for-syntax (generate-action-name nt pos) + (syntax-local-get-shadower + (datum->syntax #f (symbol+ 'action-for- nt '/ pos)))) + +(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos) + (define pattern (car alt)) + (define action (cdr alt)) + (define-values (var-indexes non-var-indexes) + (let loop ([pattern pattern] [n 1] [vars null] [nonvars null]) + (syntax-case pattern () + [(first . more) + (syntax-case #'first (! ? !!) + [! + (loop #'more (add1 n) (cons n vars) nonvars)] + [(! . _) + (raise-syntax-error 'split + "misuse of ! grammar form" + pattern #'first)] + [!! + (when (pair? (syntax-e #'more)) (raise-syntax-error 'split - "misuse of ! grammar form" - pattern #'first)] - [!! - (when (pair? (syntax-e #'more)) - (raise-syntax-error 'split - "nothing may follow !!" - pattern)) - (loop #'more (add1 n) (cons n vars) nonvars)] - [(!! . _) - (raise-syntax-error 'split - "misuse of !! grammar form" - pattern #'first)] - [(? NT) - (identifier? #'NT) - (loop #'more (add1 n) (cons n vars) nonvars)] - [(? . _) - (raise-syntax-error 'split - "misuse of ? grammar form" - pattern #'first)] - [NT - (identifier? #'NT) - (loop #'more (add1 n) (cons n vars) nonvars)] - [other - (raise-syntax-error 'rewrite-pattern - "invalid grammar pattern" - pattern #'first)])] - [() - (values (reverse vars) (reverse nonvars))]))) - (define variables (map $name var-indexes)) - (define non-var-names (map $name non-var-indexes)) - (define action-function (generate-action-name nt pos)) - (cons (cons pattern action-function) - (with-syntax ([(var ...) variables] - [(nonvar ...) non-var-names] - [action-function action-function] - [action action]) - #`(define (action-function wrap var ...) - (let-syntax ([nonvar invalid-$name-use] ...) - #,(if args-spec - #`(lambda #,args-spec (wrap action)) - #`(wrap action))))))) + "nothing may follow !!" + pattern)) + (loop #'more (add1 n) (cons n vars) nonvars)] + [(!! . _) + (raise-syntax-error 'split + "misuse of !! grammar form" + pattern #'first)] + [(? NT) + (identifier? #'NT) + (loop #'more (add1 n) (cons n vars) nonvars)] + [(? . _) + (raise-syntax-error 'split + "misuse of ? grammar form" + pattern #'first)] + [NT + (identifier? #'NT) + (loop #'more (add1 n) (cons n vars) nonvars)] + [other + (raise-syntax-error 'rewrite-pattern + "invalid grammar pattern" + pattern #'first)])] + [() + (values (reverse vars) (reverse nonvars))]))) + (define variables (map $name var-indexes)) + (define non-var-names (map $name non-var-indexes)) + (define action-function (generate-action-name nt pos)) + (cons (cons pattern action-function) + (with-syntax ([(var ...) variables] + [(nonvar ...) non-var-names] + [action-function action-function] + [action action]) + #`(define (action-function wrap var ...) + (let-syntax ([nonvar invalid-$name-use] ...) + #,(if args-spec + #`(lambda #,args-spec (wrap action)) + #`(wrap action))))))) - (define-for-syntax (invalid-$name-use stx) - (raise-syntax-error #f "no value for positional variable" stx)) +(define-for-syntax (invalid-$name-use stx) + (raise-syntax-error #f "no value for positional variable" stx)) - ;; An alternate is (cons pattern action-expr) - ;; An alternate* is (cons pattern action-function-name) +;; An alternate is (cons pattern action-expr) +;; An alternate* is (cons pattern action-function-name) - (define-for-syntax ((make-production-splitter okW intW) stx) - (syntax-case stx () - [(_ (name form ...)) - (let () - (define-values (options alternates0) - (partition-options/alternates (syntax->list #'(form ...)))) - (define wrap? - (let ([wrap? (assq #:wrap options)] - [no-wrap? (assq #:no-wrap options)]) - (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?))) - (raise-syntax-error 'split - "must specify exactly one of #:wrap, #:no-wrap" - stx)) - (and wrap? #t))) - (define args-spec - (let ([p (assq #:args options)]) (and p (cdr p)))) - (define rewrite-alt+def (make-rewrite-alt+def #'name args-spec)) - (define alternates+definitions - (map rewrite-alt+def alternates0 (build-list (length alternates0) add1))) - (define alternates (map car alternates+definitions)) - (define action-definitions (map cdr alternates+definitions)) - (define elaborate-successful-alternate - (make-elaborate-successful-alternate wrap? okW)) - (define elaborate-interrupted-alternate - (make-elaborate-interrupted-alternate wrap? intW)) - (define successful-alternates - (apply append (map elaborate-successful-alternate alternates))) - (define interrupted-alternates - (apply append (map elaborate-interrupted-alternate alternates))) - (with-syntax ([((success-pattern . success-action) ...) - successful-alternates] - [((interrupted-pattern . interrupted-action) ...) - interrupted-alternates] - [skip-spec (assq #:skipped options)] - [args-spec (assq #:args options)] - [name/Skipped (I (symbol+ #'name '/Skipped))] - [name/Interrupted (I (symbol+ #'name '/Interrupted))] - [%action ((syntax-local-certifier) #'%action)]) - #`(begin - (definitions #,@action-definitions) - (productions - (name [success-pattern success-action] ...) - #,(if (pair? interrupted-alternates) - #'(name/Interrupted [interrupted-pattern interrupted-action] - ...) - #'(name/Interrupted [(IMPOSSIBLE) #f])) - (name/Skipped [() (%skipped args-spec skip-spec)])))))])) +(define-for-syntax ((make-production-splitter okW intW) stx) + (syntax-case stx () + [(_ (name form ...)) + (let () + (define-values (options alternates0) + (partition-options/alternates (syntax->list #'(form ...)))) + (define wrap? + (let ([wrap? (assq '#:wrap options)] + [no-wrap? (assq '#:no-wrap options)]) + (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?))) + (raise-syntax-error 'split + "must specify exactly one of #:wrap, #:no-wrap" + stx)) + (and wrap? #t))) + (define args-spec + (let ([p (assq '#:args options)]) (and p (cdr p)))) + (define rewrite-alt+def (make-rewrite-alt+def #'name args-spec)) + (define alternates+definitions + (map rewrite-alt+def alternates0 (build-list (length alternates0) add1))) + (define alternates (map car alternates+definitions)) + (define action-definitions (map cdr alternates+definitions)) + (define elaborate-successful-alternate + (make-elaborate-successful-alternate wrap? okW)) + (define elaborate-interrupted-alternate + (make-elaborate-interrupted-alternate wrap? intW)) + (define successful-alternates + (apply append (map elaborate-successful-alternate alternates))) + (define interrupted-alternates + (apply append (map elaborate-interrupted-alternate alternates))) + (with-syntax ([((success-pattern . success-action) ...) + successful-alternates] + [((interrupted-pattern . interrupted-action) ...) + interrupted-alternates] + [skip-spec (assq '#:skipped options)] + [args-spec (assq '#:args options)] + [name/Skipped (I (symbol+ #'name '/Skipped))] + [name/Interrupted (I (symbol+ #'name '/Interrupted))] + [%action ((syntax-local-certifier) #'%action)]) + #`(begin + (definitions #,@action-definitions) + (productions + (name [success-pattern success-action] ...) + #,(if (pair? interrupted-alternates) + #'(name/Interrupted [interrupted-pattern interrupted-action] + ...) + #'(name/Interrupted [(IMPOSSIBLE) #f])) + (name/Skipped [() (%skipped args-spec skip-spec)])))))])) - (define-syntax (skipped-token-values stx) - (syntax-case stx () - [(skipped-token-values) - #'(begin)] - [(skipped-token-values name . more) - (identifier? #'name) - (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) - #'(begin (productions (name/Skipped [() #f])) - (skipped-token-values . more)))] - [(skipped-token-values (name value) . more) - (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) - #'(begin (productions (name/Skipped [() value])) - (skipped-token-values . more)))])) +(define-syntax (skipped-token-values stx) + (syntax-case stx () + [(skipped-token-values) + #'(begin)] + [(skipped-token-values name . more) + (identifier? #'name) + (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) + #'(begin (productions (name/Skipped [() #f])) + (skipped-token-values . more)))] + [(skipped-token-values (name value) . more) + (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) + #'(begin (productions (name/Skipped [() value])) + (skipped-token-values . more)))])) - (define-syntax (%skipped stx) - (syntax-case stx () - [(%skipped args (#:skipped . expr)) - #'(%action args expr)] - [(%skipped args #f) - #'(%action args #f)])) +(define-syntax (%skipped stx) + (syntax-case stx () + [(%skipped args (#:skipped . expr)) + #'(%action args expr)] + [(%skipped args #f) + #'(%action args #f)])) - (define-syntax (%action stx) - (syntax-case stx () - [(%action (#:args . args) action) - #'(lambda args action)] - [(%action #f action) - #'action])) - ) +(define-syntax (%action stx) + (syntax-case stx () + [(%action (#:args . args) action) + #'(lambda args action)] + [(%action #f action) + #'action])) diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss index 2c256be..3d9ab99 100644 --- a/collects/macro-debugger/stepper-text.ss +++ b/collects/macro-debugger/stepper-text.ss @@ -1,140 +1,139 @@ -(module stepper-text mzscheme - (require (lib "list.ss") - (lib "pretty.ss") - "model/trace.ss" - "model/reductions.ss" - "model/steps.ss" - "model/hide.ss" - "model/hiding-policies.ss" - "syntax-browser/partition.ss" - "syntax-browser/pretty-helper.ss") - (provide expand/step-text - stepper-text) +#lang scheme/base +(require scheme/list + scheme/pretty + "model/trace.ss" + "model/reductions.ss" + "model/steps.ss" + "model/hide.ss" + "model/hiding-policies.ss" + "syntax-browser/partition.ss" + "syntax-browser/pretty-helper.ss") +(provide expand/step-text + stepper-text) - (define expand/step-text - (case-lambda - [(stx) (expand/step-text stx #f)] - [(stx show) - (define s (stepper-text stx (->show-function show))) - (s 'all)])) - - (define stepper-text +(define expand/step-text + (case-lambda + [(stx) (expand/step-text stx #f)] + [(stx show) + (define s (stepper-text stx (->show-function show))) + (s 'all)])) + +(define stepper-text + (case-lambda + [(stx) (internal-stepper stx #f)] + [(stx show) (internal-stepper stx (->show-function show))])) + +;; internal procedures + +(define (internal-stepper stx show?) + (define steps (get-steps stx show?)) + (define used-steps null) + (define partition (new-bound-partition)) + (define dispatch (case-lambda - [(stx) (internal-stepper stx #f)] - [(stx show) (internal-stepper stx (->show-function show))])) - - ;; internal procedures + [() (dispatch 'next)] + [(sym) + (case sym + ((next) + (if (pair? steps) + (begin (show-step (car steps) partition) + (set! used-steps (cons (car steps) used-steps)) + (set! steps (cdr steps))) + #f)) + ((prev) + (if (pair? used-steps) + (begin (show-step (car used-steps) partition) + (set! steps (cons (car used-steps) steps)) + (set! used-steps (cdr used-steps))) + #f)) + ((all) + (when (pair? steps) + (dispatch 'next) + (dispatch 'all))))])) + dispatch) - (define (internal-stepper stx show?) - (define steps (get-steps stx show?)) - (define used-steps null) - (define partition (new-bound-partition)) - (define dispatch - (case-lambda - [() (dispatch 'next)] - [(sym) - (case sym - ((next) - (if (pair? steps) - (begin (show-step (car steps) partition) - (set! used-steps (cons (car steps) used-steps)) - (set! steps (cdr steps))) - #f)) - ((prev) - (if (pair? used-steps) - (begin (show-step (car used-steps) partition) - (set! steps (cons (car used-steps) steps)) - (set! used-steps (cdr used-steps))) - #f)) - ((all) - (when (pair? steps) - (dispatch 'next) - (dispatch 'all))))])) - dispatch) - - (define (get-steps stx show?) - (define deriv (trace stx)) - (define hderiv - (if show? (hide/policy deriv show?) deriv)) - (define (ok? x) - (or (rewrite-step? x) (misstep? x))) - (filter ok? (reductions hderiv))) - - (define (show-step step partition) - (cond [(step? step) - (display (step-type->string (protostep-type step))) - (newline) - (show-term (step-term1 step) partition) - (display " ==>") - (newline) - (show-term (step-term2 step) partition) - (newline)] - [(misstep? step) - (display (exn-message (misstep-exn step))) - (newline) - (show-term (misstep-term1 step) partition)])) - - (define (show-term stx partition) - (define-values (datum flat=>stx stx=>flat) - (table stx partition 0 'always)) - (define identifier-list - (filter identifier? (hash-table-map stx=>flat (lambda (k v) k)))) - (define (pp-size-hook obj display-like? port) - (cond [(syntax-dummy? obj) - (let ((ostring (open-output-string))) - ((if display-like? display write) - (syntax-dummy-val obj) - ostring) - (string-length (get-output-string ostring)))] - [else #f])) - (define (pp-print-hook obj display-like? port) - (cond [(syntax-dummy? obj) - ((if display-like? display write) (syntax-dummy-val obj) port)] - [else - (error 'pretty-print-hook "unexpected special value: ~e" obj)])) - (define (pp-extend-style-table) - (let* ([ids identifier-list] - [syms (map (lambda (x) (hash-table-get stx=>flat x)) ids)] - [like-syms (map syntax-e ids)]) - (pretty-print-extend-style-table (pp-better-style-table) - syms - like-syms))) - (define (pp-better-style-table) - (pretty-print-extend-style-table (pretty-print-current-style-table) - (map car extended-style-list) - (map cdr extended-style-list))) - (parameterize - ([pretty-print-size-hook pp-size-hook] - [pretty-print-print-hook pp-print-hook] - [pretty-print-current-style-table (pp-extend-style-table)] - ;; Printing parameters (mzscheme manual 7.9.1.4) - [print-unreadable #t] - [print-graph #f] - [print-struct #f] - [print-box #t] - [print-vector-length #t] - [print-hash-table #f] - [print-honu #f]) - (pretty-print datum))) - - (define (->show-function show) - (cond [(procedure? show) - show] - [(list? show) - (lambda (id) - (ormap (lambda (x) (module-identifier=? x id)) - show))] - [(hiding-policy? show) - (lambda (x) (policy-show-macro? show x))] - [(eq? show #f) - #f] - [else - (error 'expand/trace-text - "expected procedure or list of identifiers for macros to show; got: ~e" - show)])) +(define (get-steps stx show?) + (define deriv (trace stx)) + (define hderiv + (if show? (hide/policy deriv show?) deriv)) + (define (ok? x) + (or (rewrite-step? x) (misstep? x))) + (filter ok? (reductions hderiv))) - (define extended-style-list - '((define-values . define) - (define-syntaxes . define-syntax))) - ) \ No newline at end of file +(define (show-step step partition) + (cond [(step? step) + (display (step-type->string (protostep-type step))) + (newline) + (show-term (step-term1 step) partition) + (display " ==>") + (newline) + (show-term (step-term2 step) partition) + (newline)] + [(misstep? step) + (display (exn-message (misstep-exn step))) + (newline) + (show-term (misstep-term1 step) partition)])) + +(define (show-term stx partition) + (define-values (datum flat=>stx stx=>flat) + (table stx partition 0 'always)) + (define identifier-list + (filter identifier? (hash-table-map stx=>flat (lambda (k v) k)))) + (define (pp-size-hook obj display-like? port) + (cond [(syntax-dummy? obj) + (let ((ostring (open-output-string))) + ((if display-like? display write) + (syntax-dummy-val obj) + ostring) + (string-length (get-output-string ostring)))] + [else #f])) + (define (pp-print-hook obj display-like? port) + (cond [(syntax-dummy? obj) + ((if display-like? display write) (syntax-dummy-val obj) port)] + [else + (error 'pretty-print-hook "unexpected special value: ~e" obj)])) + (define (pp-extend-style-table) + (let* ([ids identifier-list] + [syms (map (lambda (x) (hash-table-get stx=>flat x)) ids)] + [like-syms (map syntax-e ids)]) + (pretty-print-extend-style-table (pp-better-style-table) + syms + like-syms))) + (define (pp-better-style-table) + (pretty-print-extend-style-table (pretty-print-current-style-table) + (map car extended-style-list) + (map cdr extended-style-list))) + (parameterize + ([pretty-print-size-hook pp-size-hook] + [pretty-print-print-hook pp-print-hook] + [pretty-print-current-style-table (pp-extend-style-table)] + ;; Printing parameters (mzscheme manual 7.9.1.4) + [print-unreadable #t] + [print-graph #f] + [print-struct #f] + [print-box #t] + [print-vector-length #t] + [print-hash-table #f] + [print-honu #f]) + (pretty-print datum))) + +(define (->show-function show) + (cond [(procedure? show) + show] + [(list? show) + (lambda (id) + (ormap (lambda (x) (free-identifier=? x id)) + show))] + [(hiding-policy? show) + (lambda (x) (policy-show-macro? show x))] + [(eq? show #f) + #f] + [else + (error 'expand/trace-text + "expected procedure or list of identifiers for macros to show; got: ~e" + show)])) + +(define extended-style-list + '((define-values . define) + (define-syntaxes . define-syntax))) diff --git a/collects/macro-debugger/stepper.ss b/collects/macro-debugger/stepper.ss index 624b955..30fec39 100644 --- a/collects/macro-debugger/stepper.ss +++ b/collects/macro-debugger/stepper.ss @@ -1,8 +1,7 @@ -(module stepper mzscheme - (require "view/view.ss") - (provide expand/step) - - (define (expand/step stx) - (go stx)) - ) +#lang scheme/base +(require "view/view.ss") +(provide expand/step) + +(define (expand/step stx) + (go stx)) diff --git a/collects/macro-debugger/syntax-browser.ss b/collects/macro-debugger/syntax-browser.ss index deda135..ce23cef 100644 --- a/collects/macro-debugger/syntax-browser.ss +++ b/collects/macro-debugger/syntax-browser.ss @@ -1,7 +1,6 @@ -(module syntax-browser mzscheme - (require "syntax-browser/frame.ss") - (provide browse-syntax - browse-syntaxes - make-syntax-browser) - ) +#lang scheme/base +(require "syntax-browser/frame.ss") +(provide browse-syntax + browse-syntaxes + make-syntax-browser) diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index 7882d4f..19451d6 100644 --- a/collects/macro-debugger/syntax-browser/controller.ss +++ b/collects/macro-debugger/syntax-browser/controller.ss @@ -1,76 +1,75 @@ -(module controller mzscheme - (require (lib "class.ss") - "interfaces.ss" - "partition.ss" - "../util/notify.ss") - (provide controller%) +#lang scheme/base +(require scheme/class + "interfaces.ss" + "partition.ss" + "../util/notify.ss") +(provide controller%) - ;; displays-manager-mixin - (define displays-manager-mixin - (mixin () (displays-manager<%>) - ;; displays : (list-of display<%>) - (field [displays null]) +;; displays-manager-mixin +(define displays-manager-mixin + (mixin () (displays-manager<%>) + ;; displays : (list-of display<%>) + (field [displays null]) - ;; add-syntax-display : display<%> -> void - (define/public (add-syntax-display c) - (set! displays (cons c displays))) + ;; add-syntax-display : display<%> -> void + (define/public (add-syntax-display c) + (set! displays (cons c displays))) - ;; remove-all-syntax-displays : -> void - (define/public (remove-all-syntax-displays) - (set! displays null)) + ;; remove-all-syntax-displays : -> void + (define/public (remove-all-syntax-displays) + (set! displays null)) - (super-new))) + (super-new))) - ;; selection-manager-mixin - (define selection-manager-mixin - (mixin (displays-manager<%>) (selection-manager<%>) - (inherit-field displays) - (field/notify selected-syntax (new notify-box% (value #f))) - - (super-new) - (listen-selected-syntax - (lambda (new-value) - (for-each (lambda (display) (send display refresh)) - displays))))) - - ;; mark-manager-mixin - (define mark-manager-mixin - (mixin () (mark-manager<%>) - (init-field [primary-partition (new-bound-partition)]) - (super-new) +;; selection-manager-mixin +(define selection-manager-mixin + (mixin (displays-manager<%>) (selection-manager<%>) + (inherit-field displays) + (field/notify selected-syntax (new notify-box% (value #f))) + + (super-new) + (listen-selected-syntax + (lambda (new-value) + (for-each (lambda (display) (send display refresh)) + displays))))) - ;; get-primary-partition : -> partition - (define/public-final (get-primary-partition) - primary-partition) +;; mark-manager-mixin +(define mark-manager-mixin + (mixin () (mark-manager<%>) + (init-field [primary-partition (new-bound-partition)]) + (super-new) - ;; reset-primary-partition : -> void - (define/public-final (reset-primary-partition) - (set! primary-partition (new-bound-partition))))) + ;; get-primary-partition : -> partition + (define/public-final (get-primary-partition) + primary-partition) - ;; secondary-partition-mixin - (define secondary-partition-mixin - (mixin (displays-manager<%>) (secondary-partition<%>) - (inherit-field displays) - (field/notify identifier=? (new notify-box% (value #f))) - (field/notify secondary-partition (new notify-box% (value #f))) + ;; reset-primary-partition : -> void + (define/public-final (reset-primary-partition) + (set! primary-partition (new-bound-partition))))) - (listen-identifier=? - (lambda (name+proc) - (set-secondary-partition - (and name+proc - (new partition% (relation (cdr name+proc))))))) - (listen-secondary-partition - (lambda (p) - (for-each (lambda (d) (send d refresh)) - displays))) - (super-new))) +;; secondary-partition-mixin +(define secondary-partition-mixin + (mixin (displays-manager<%>) (secondary-partition<%>) + (inherit-field displays) + (field/notify identifier=? (new notify-box% (value #f))) + (field/notify secondary-partition (new notify-box% (value #f))) - (define controller% - (class (secondary-partition-mixin - (selection-manager-mixin - (mark-manager-mixin - (displays-manager-mixin - object%)))) - (super-new))) - ) + (listen-identifier=? + (lambda (name+proc) + (set-secondary-partition + (and name+proc + (new partition% (relation (cdr name+proc))))))) + (listen-secondary-partition + (lambda (p) + (for-each (lambda (d) (send d refresh)) + displays))) + (super-new))) + +(define controller% + (class (secondary-partition-mixin + (selection-manager-mixin + (mark-manager-mixin + (displays-manager-mixin + object%)))) + (super-new))) diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index dd0fbef..f7abc68 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -1,251 +1,250 @@ -(module display mzscheme - (require (lib "class.ss") - (lib "mred.ss" "mred") - (lib "plt-match.ss") - "params.ss" - "pretty-printer.ss" - "interfaces.ss" - "util.ss") - (provide print-syntax-to-editor - code-style) +#lang scheme/base +(require scheme/class + scheme/gui + scheme/match + "params.ss" + "pretty-printer.ss" + "interfaces.ss" + "util.ss") +(provide print-syntax-to-editor + code-style) - ;; print-syntax-to-editor : syntax text controller<%> -> display<%> - (define (print-syntax-to-editor stx text controller) - (new display% (syntax stx) (text text) (controller controller))) +;; print-syntax-to-editor : syntax text controller<%> -> display<%> +(define (print-syntax-to-editor stx text controller) + (new display% (syntax stx) (text text) (controller controller))) - ;; FIXME: assumes text never moves +;; FIXME: assumes text never moves - ;; display% - (define display% - (class* object% (display<%>) - (init ((stx syntax))) - (init-field text) - (init-field controller) +;; display% +(define display% + (class* object% (display<%>) + (init ((stx syntax))) + (init-field text) + (init-field controller) - (define start-anchor (new anchor-snip%)) - (define end-anchor (new anchor-snip%)) - (define range #f) - (define extra-styles (make-hash-table)) + (define start-anchor (new anchor-snip%)) + (define end-anchor (new anchor-snip%)) + (define range #f) + (define extra-styles (make-hash-table)) - ;; render-syntax : syntax -> void - (define/public (render-syntax stx) - (with-unlock text - (send text delete (get-start-position) (get-end-position)) - (set! range - (print-syntax stx text controller - (lambda () (get-start-position)) - (lambda () (get-end-position)))) - (apply-primary-partition-styles)) - (refresh)) + ;; render-syntax : syntax -> void + (define/public (render-syntax stx) + (with-unlock text + (send text delete (get-start-position) (get-end-position)) + (set! range + (print-syntax stx text controller + (lambda () (get-start-position)) + (lambda () (get-end-position)))) + (apply-primary-partition-styles)) + (refresh)) - ;; refresh : -> void - ;; Clears all highlighting and reapplies all non-foreground styles. - (define/public (refresh) - (with-unlock text - (send* text - (begin-edit-sequence) - (change-style unhighlight-d (get-start-position) (get-end-position))) - (apply-extra-styles) - (let ([selected-syntax (send controller get-selected-syntax)]) - (apply-secondary-partition-styles selected-syntax) - (apply-selection-styles selected-syntax)) - (send* text - (end-edit-sequence)))) + ;; refresh : -> void + ;; Clears all highlighting and reapplies all non-foreground styles. + (define/public (refresh) + (with-unlock text + (send* text + (begin-edit-sequence) + (change-style unhighlight-d (get-start-position) (get-end-position))) + (apply-extra-styles) + (let ([selected-syntax (send controller get-selected-syntax)]) + (apply-secondary-partition-styles selected-syntax) + (apply-selection-styles selected-syntax)) + (send* text + (end-edit-sequence)))) - ;; cached-start-position : number - (define cached-start-position #f) + ;; cached-start-position : number + (define cached-start-position #f) - ;; get-start-position : -> number - (define/public-final (get-start-position) - (unless cached-start-position - (set! cached-start-position (send text get-snip-position start-anchor))) - cached-start-position) + ;; get-start-position : -> number + (define/public-final (get-start-position) + (unless cached-start-position + (set! cached-start-position (send text get-snip-position start-anchor))) + cached-start-position) - ;; get-end-position : -> number - (define/public-final (get-end-position) - (send text get-snip-position end-anchor)) + ;; get-end-position : -> number + (define/public-final (get-end-position) + (send text get-snip-position end-anchor)) - ;; relative->text-position : number -> number - ;; FIXME: might be slow to find start every time! - (define/public-final (relative->text-position pos) - (+ pos (get-start-position))) + ;; relative->text-position : number -> number + ;; FIXME: might be slow to find start every time! + (define/public-final (relative->text-position pos) + (+ pos (get-start-position))) - ;; Styling + ;; Styling - ;; get-range : -> range<%> - (define/public (get-range) range) - - ;; highlight-syntaxes : (list-of syntax) string -> void - (define/public (highlight-syntaxes stxs hi-color) - (let ([style-delta (highlight-style-delta hi-color #f)]) - (for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta)) - stxs)) - (refresh)) + ;; get-range : -> range<%> + (define/public (get-range) range) + + ;; highlight-syntaxes : (list-of syntax) string -> void + (define/public (highlight-syntaxes stxs hi-color) + (let ([style-delta (highlight-style-delta hi-color #f)]) + (for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta)) + stxs)) + (refresh)) - ;; apply-extra-styles : -> void - ;; Applies externally-added styles (such as highlighting) - (define/private (apply-extra-styles) - (hash-table-for-each - extra-styles - (lambda (hi-stx style-delta) - (let ([rs (send range get-ranges hi-stx)]) - (for-each (lambda (r) (restyle-range r style-delta)) rs))))) + ;; apply-extra-styles : -> void + ;; Applies externally-added styles (such as highlighting) + (define/private (apply-extra-styles) + (hash-table-for-each + extra-styles + (lambda (hi-stx style-delta) + (let ([rs (send range get-ranges hi-stx)]) + (for-each (lambda (r) (restyle-range r style-delta)) rs))))) - ;; 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 get-secondary-partition)]) - (when partition - (for-each (lambda (id) - (when (send partition same-partition? selected-syntax id) - (draw-secondary-connection id))) - (send range get-identifier-list)))))) + ;; 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 get-secondary-partition)]) + (when partition + (for-each (lambda (id) + (when (send partition same-partition? selected-syntax id) + (draw-secondary-connection id))) + (send range get-identifier-list)))))) - ;; apply-selection-styles : syntax -> void - ;; Styles subterms eq to the selected syntax - (define/private (apply-selection-styles selected-syntax) - (let ([rs (send range get-ranges selected-syntax)]) - (for-each (lambda (r) (restyle-range r select-highlight-d)) rs))) + ;; apply-selection-styles : syntax -> void + ;; Styles subterms eq to the selected syntax + (define/private (apply-selection-styles selected-syntax) + (let ([rs (send range get-ranges selected-syntax)]) + (for-each (lambda (r) (restyle-range r select-highlight-d)) rs))) - ;; draw-secondary-connection : syntax -> void - (define/private (draw-secondary-connection stx2) - (let ([rs (send range get-ranges stx2)]) - (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs))) + ;; draw-secondary-connection : syntax -> void + (define/private (draw-secondary-connection stx2) + (let ([rs (send range get-ranges stx2)]) + (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs))) - ;; 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)))) + ;; 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)))) - ;; Primary styles + ;; Primary styles - ;; 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 (color-style color) - (let ([delta (new style-delta%)]) - (send delta set-delta-foreground color) - delta)) - (define color-styles (list->vector (map color-style (current-colors)))) - (define overflow-style (color-style "darkgray")) - (define color-partition (send controller get-primary-partition)) - (define offset (get-start-position)) - (for-each - (lambda (range) - (let ([stx (range-obj range)] - [start (range-start range)] - [end (range-end range)]) - (send text change-style - (primary-style stx color-partition color-styles overflow-style) - (+ offset start) - (+ offset end)))) - (send range all-ranges))) + ;; 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 (color-style color) + (let ([delta (new style-delta%)]) + (send delta set-delta-foreground color) + delta)) + (define color-styles (list->vector (map color-style (current-colors)))) + (define overflow-style (color-style "darkgray")) + (define color-partition (send controller get-primary-partition)) + (define offset (get-start-position)) + (for-each + (lambda (range) + (let ([stx (range-obj range)] + [start (range-start range)] + [end (range-end range)]) + (send text change-style + (primary-style stx color-partition color-styles overflow-style) + (+ offset start) + (+ offset end)))) + (send range all-ranges))) - ;; 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 get-partition stx)]) - (cond [(< n (vector-length color-vector)) - (vector-ref color-vector n)] - [else - overflow]))) + ;; 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 get-partition stx)]) + (cond [(< n (vector-length color-vector)) + (vector-ref color-vector n)] + [else + overflow]))) - ;; Initialize - (super-new) - (send text insert start-anchor) - (send text insert end-anchor) - (render-syntax stx) - (send controller add-syntax-display this))) + ;; Initialize + (super-new) + (send text insert start-anchor) + (send text insert end-anchor) + (render-syntax stx) + (send controller add-syntax-display this))) - ;; print-syntax : syntax controller (-> number) (-> number) - ;; -> range% - (define (print-syntax stx text controller - get-start-position get-end-position) - (define primary-partition (send controller get-primary-partition)) - (define real-output-port (make-text-port text get-end-position)) - (define output-port (open-output-string)) +;; print-syntax : syntax controller (-> number) (-> number) +;; -> range% +(define (print-syntax stx text controller + get-start-position get-end-position) + (define primary-partition (send controller get-primary-partition)) + (define real-output-port (make-text-port text get-end-position)) + (define output-port (open-output-string)) - (port-count-lines! output-port) - (let ([range (pretty-print-syntax stx output-port primary-partition)]) - (write-string (get-output-string output-port) real-output-port) - (let ([end (get-end-position)]) - ;; Pretty printer always inserts final newline; we remove it here. - (send text delete (sub1 end) end)) - ;; Set font to standard - (send text change-style - (code-style text) - (get-start-position) - (get-end-position)) - (let ([offset (get-start-position)]) - (fixup-parentheses text range offset) - (for-each - (lambda (range) - (let* ([stx (range-obj range)] - [start (range-start range)] - [end (range-end range)]) - (send text set-clickback (+ offset start) (+ offset end) - (lambda (_1 _2 _3) - (send controller set-selected-syntax stx))))) - (send range all-ranges)) - range))) + (port-count-lines! output-port) + (let ([range (pretty-print-syntax stx output-port primary-partition)]) + (write-string (get-output-string output-port) real-output-port) + (let ([end (get-end-position)]) + ;; Pretty printer always inserts final newline; we remove it here. + (send text delete (sub1 end) end)) + ;; Set font to standard + (send text change-style + (code-style text) + (get-start-position) + (get-end-position)) + (let ([offset (get-start-position)]) + (fixup-parentheses text range offset) + (for-each + (lambda (range) + (let* ([stx (range-obj range)] + [start (range-start range)] + [end (range-end range)]) + (send text set-clickback (+ offset start) (+ offset end) + (lambda (_1 _2 _3) + (send controller set-selected-syntax stx))))) + (send range all-ranges)) + range))) - ;; fixup-parentheses : text range -> void - (define (fixup-parentheses text range offset) - (define (fixup r) - (let ([stx (range-obj r)] - [start (+ offset (range-start r))] - [end (+ offset (range-end r))]) - (when (and (syntax? stx) (pair? (syntax-e stx))) - (case (syntax-property stx 'paren-shape) - ((#\[) - (replace start #\[) - (replace (sub1 end) #\])) - ((#\{) - (replace start #\{) - (replace (sub1 end) #\})))))) - (define (replace pos char) - (send text insert char pos (add1 pos))) - (for-each fixup (send range all-ranges))) +;; fixup-parentheses : text range -> void +(define (fixup-parentheses text range offset) + (define (fixup r) + (let ([stx (range-obj r)] + [start (+ offset (range-start r))] + [end (+ offset (range-end r))]) + (when (and (syntax? stx) (pair? (syntax-e stx))) + (case (syntax-property stx 'paren-shape) + ((#\[) + (replace start #\[) + (replace (sub1 end) #\])) + ((#\{) + (replace start #\{) + (replace (sub1 end) #\})))))) + (define (replace pos char) + (send text insert char pos (add1 pos))) + (for-each fixup (send range all-ranges))) - ;; code-style : text<%> -> style<%> - (define (code-style text) - (let* ([style-list (send text get-style-list)] - [style (send style-list find-named-style "Standard")] - [font-size (current-syntax-font-size)]) - (if font-size - (send style-list find-or-create-style - style - (make-object style-delta% 'change-size font-size)) - style))) +;; code-style : text<%> -> style<%> +(define (code-style text) + (let* ([style-list (send text get-style-list)] + [style (send style-list find-named-style "Standard")] + [font-size (current-syntax-font-size)]) + (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 ()))) +;; anchor-snip% +(define anchor-snip% + (class snip% + (define/override (copy) + (make-object string-snip% "")) + (super-instantiate ()))) - ;; Styles +;; 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 (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 selection-color "yellow") - (define subselection-color "yellow") +(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 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)) +(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.ss index 69ad4e0..7c46e85 100644 --- a/collects/macro-debugger/syntax-browser/embed.ss +++ b/collects/macro-debugger/syntax-browser/embed.ss @@ -1,13 +1,13 @@ -(module embed mzscheme - (require "interfaces.ss" - "widget.ss" - "keymap.ss" - "params.ss" - "partition.ss") - - (provide (all-from "interfaces.ss") - (all-from "widget.ss") - (all-from "keymap.ss") - (all-from "params.ss") - identifier=-choices)) +#lang scheme/base +(require "interfaces.ss" + "widget.ss" + "keymap.ss" + "params.ss" + "partition.ss") + +(provide (all-from-out "interfaces.ss") + (all-from-out "widget.ss") + (all-from-out "keymap.ss") + (all-from-out "params.ss") + identifier=-choices) diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.ss index a94f5c7..1abce48 100644 --- a/collects/macro-debugger/syntax-browser/frame.ss +++ b/collects/macro-debugger/syntax-browser/frame.ss @@ -1,96 +1,94 @@ -(module frame mzscheme - (require (lib "class.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - (lib "list.ss") - "partition.ss" - "prefs.ss" - "widget.ss") - (provide browse-syntax - browse-syntaxes - make-syntax-browser - syntax-browser-frame% - syntax-widget/controls%) +#lang scheme/base +(require scheme/class + scheme/gui + framework/framework + scheme/list + "partition.ss" + "prefs.ss" + "widget.ss") +(provide browse-syntax + browse-syntaxes + make-syntax-browser + syntax-browser-frame% + syntax-widget/controls%) - ;; browse-syntax : syntax -> void - (define (browse-syntax stx) - (browse-syntaxes (list stx))) +;; browse-syntax : syntax -> void +(define (browse-syntax stx) + (browse-syntaxes (list stx))) - ;; browse-syntaxes : (list-of syntax) -> void - (define (browse-syntaxes stxs) - (let ((w (make-syntax-browser))) - (for-each (lambda (stx) - (send w add-syntax stx) - (send w add-separator)) - stxs))) +;; browse-syntaxes : (list-of syntax) -> void +(define (browse-syntaxes stxs) + (let ((w (make-syntax-browser))) + (for-each (lambda (stx) + (send w add-syntax stx) + (send w add-separator)) + stxs))) - ;; make-syntax-browser : -> syntax-browser<%> - (define (make-syntax-browser) - (let* ([view (new syntax-browser-frame%)]) - (send view show #t) - (send view get-widget))) +;; make-syntax-browser : -> syntax-browser<%> +(define (make-syntax-browser) + (let* ([view (new syntax-browser-frame%)]) + (send view show #t) + (send view get-widget))) - ;; syntax-browser-frame% - (define syntax-browser-frame% - (class* frame% () - (init-field [config (new syntax-prefs%)]) - (super-new (label "Syntax Browser") - (width (send config pref:width)) - (height (send config pref:height))) - (define widget - (new syntax-widget/controls% - (parent this) - (config config))) - (define/public (get-widget) widget) - (define/augment (on-close) - (send config pref:width (send this get-width)) - (send config pref:height (send this get-height)) - (send widget shutdown) - (inner (void) on-close)) - )) +;; syntax-browser-frame% +(define syntax-browser-frame% + (class* frame% () + (init-field [config (new syntax-prefs%)]) + (super-new (label "Syntax Browser") + (width (send config pref:width)) + (height (send config pref:height))) + (define widget + (new syntax-widget/controls% + (parent this) + (config config))) + (define/public (get-widget) widget) + (define/augment (on-close) + (send config pref:width (send this get-width)) + (send config pref:height (send this get-height)) + (send widget shutdown) + (inner (void) on-close)) + )) - ;; syntax-widget/controls% - (define syntax-widget/controls% - (class* widget% () - (inherit get-main-panel - get-controller - toggle-props) - (super-new) - (inherit-field config) +;; syntax-widget/controls% +(define syntax-widget/controls% + (class* widget% () + (inherit get-main-panel + get-controller + toggle-props) + (super-new) + (inherit-field config) - (define -control-panel - (new horizontal-pane% - (parent (get-main-panel)) - (stretchable-height #f))) + (define -control-panel + (new horizontal-pane% + (parent (get-main-panel)) + (stretchable-height #f))) - ;; Put the control panel up front - (send (get-main-panel) change-children - (lambda (children) - (cons -control-panel (remq -control-panel children)))) + ;; Put the control panel up front + (send (get-main-panel) change-children + (lambda (children) + (cons -control-panel (remq -control-panel children)))) - (define -identifier=-choices (identifier=-choices)) - (define -choice - (new choice% (label "identifer=?") (parent -control-panel) - (choices (map car -identifier=-choices)) - (callback - (lambda (c e) - (send (get-controller) set-identifier=? - (assoc (send c get-string-selection) - -identifier=-choices)))))) - (new button% - (label "Clear") - (parent -control-panel) - (callback (lambda _ (send (get-controller) select-syntax #f)))) - (new button% - (label "Properties") - (parent -control-panel) - (callback (lambda _ (toggle-props)))) + (define -identifier=-choices (identifier=-choices)) + (define -choice + (new choice% (label "identifer=?") (parent -control-panel) + (choices (map car -identifier=-choices)) + (callback + (lambda (c e) + (send (get-controller) set-identifier=? + (assoc (send c get-string-selection) + -identifier=-choices)))))) + (new button% + (label "Clear") + (parent -control-panel) + (callback (lambda _ (send (get-controller) select-syntax #f)))) + (new button% + (label "Properties") + (parent -control-panel) + (callback (lambda _ (toggle-props)))) - (send (get-controller) listen-identifier=? - (lambda (name+func) - (send -choice set-selection - (or (send -choice find-string (car name+func)) 0)))) - )) - - ) + (send (get-controller) listen-identifier=? + (lambda (name+func) + (send -choice set-selection + (or (send -choice find-string (car name+func)) 0)))) + )) diff --git a/collects/macro-debugger/syntax-browser/hrule-snip.ss b/collects/macro-debugger/syntax-browser/hrule-snip.ss index fb45593..148d3f2 100644 --- a/collects/macro-debugger/syntax-browser/hrule-snip.ss +++ b/collects/macro-debugger/syntax-browser/hrule-snip.ss @@ -1,57 +1,57 @@ -(module hrule-snip mzscheme - (require (lib "class.ss") - (lib "mred.ss" "mred")) - (provide hrule-snip%) +#lang scheme/base - ;; hrule-snip% - ;; A snip for drawing horizontal separating lines. - (define hrule-snip% - (class snip% - (inherit get-admin) - (define/override (get-extent dc x y bw bh bdescent bspace blspace brspace) - (let-values [((h) (get-xheight dc)) - ((fw fh) (send dc get-size))] - (let ([ad-x (box 0)] - [ad-y (box 0)]) - (send (get-admin) get-view-size ad-x ad-y) - #;(set-box?! bw fw) - (set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc)))) - (set-box?! bh h)))) - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (let* [(xh (get-xheight dc)) - (ny (+ y (/ xh 2)))] - (send dc draw-line x ny right ny))) - (define/private (set-box?! b v) - (when (box? b) (set-box! b v))) - (define/private (get-xheight dc) - (or cached-xheight - (let-values [((w h descent extra) (send dc get-text-extent "x"))] - (set! cached-xheight h) - h))) - (define cached-xheight #f) +(require scheme/class + scheme/gui) +(provide hrule-snip%) - ;; Snip methods - (define/override (copy) - (new hrule-snip%)) - (define/override (write stream) - (void)) - (inherit set-snipclass) - (super-new) +;; hrule-snip% +;; A snip for drawing horizontal separating lines. +(define hrule-snip% + (class snip% + (inherit get-admin) + (define/override (get-extent dc x y bw bh bdescent bspace blspace brspace) + (let-values [((h) (get-xheight dc)) + ((fw fh) (send dc get-size))] + (let ([ad-x (box 0)] + [ad-y (box 0)]) + (send (get-admin) get-view-size ad-x ad-y) + #;(set-box?! bw fw) + (set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc)))) + (set-box?! bh h)))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let* [(xh (get-xheight dc)) + (ny (+ y (/ xh 2)))] + (send dc draw-line x ny right ny))) + (define/private (set-box?! b v) + (when (box? b) (set-box! b v))) + (define/private (get-xheight dc) + (or cached-xheight + (let-values [((w h descent extra) (send dc get-text-extent "x"))] + (set! cached-xheight h) + h))) + (define cached-xheight #f) - (set-snipclass snip-class))) + ;; Snip methods + (define/override (copy) + (new hrule-snip%)) + (define/override (write stream) + (void)) + (inherit set-snipclass) + (super-new) + + (set-snipclass snip-class))) - (define hrule-snipclass% - (class snip-class% - (define/override (read stream) - (let ([str (send stream get-bytes)]) - (new hrule-snip%))) - (super-new))) - - (define snip-class (new hrule-snipclass%)) - (send snip-class set-version 1) - (send snip-class set-classname - (format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser"))) - (send (get-the-snip-class-list) add snip-class) - ) +(define hrule-snipclass% + (class snip-class% + (define/override (read stream) + (let ([str (send stream get-bytes)]) + (new hrule-snip%))) + (super-new))) + +(define snip-class (new hrule-snipclass%)) +(send snip-class set-version 1) +(send snip-class set-classname + (format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser"))) +(send (get-the-snip-class-list) add snip-class) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index dc35d1d..d01315e 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -1,167 +1,165 @@ -(module interfaces mzscheme - (require (lib "class.ss")) - (provide (all-defined)) +#lang scheme/base +(require scheme/class) +(provide (all-defined-out)) - ;; displays-manager<%> - (define displays-manager<%> - (interface () - ;; add-syntax-display : display<%> -> void - add-syntax-display +;; displays-manager<%> +(define displays-manager<%> + (interface () + ;; add-syntax-display : display<%> -> void + add-syntax-display - ;; remove-all-syntax-displays : -> void - remove-all-syntax-displays)) + ;; remove-all-syntax-displays : -> void + remove-all-syntax-displays)) - ;; selection-manager<%> - (define selection-manager<%> - (interface () - ;; selected-syntax : syntax/#f - set-selected-syntax - get-selected-syntax - listen-selected-syntax - )) +;; selection-manager<%> +(define selection-manager<%> + (interface () + ;; selected-syntax : syntax/#f + set-selected-syntax + get-selected-syntax + listen-selected-syntax + )) - ;; mark-manager<%> - ;; Manages marks, mappings from marks to colors - (define mark-manager<%> - (interface () - ;; get-primary-partition : -> partition - get-primary-partition)) +;; mark-manager<%> +;; Manages marks, mappings from marks to colors +(define mark-manager<%> + (interface () + ;; get-primary-partition : -> partition + get-primary-partition)) - ;; secondary-partition<%> - (define secondary-partition<%> - (interface (displays-manager<%>) - ;; get-secondary-partition : -> partition<%> - get-secondary-partition +;; secondary-partition<%> +(define secondary-partition<%> + (interface (displays-manager<%>) + ;; get-secondary-partition : -> partition<%> + get-secondary-partition - ;; set-secondary-partition : partition<%> -> void - set-secondary-partition + ;; set-secondary-partition : partition<%> -> void + set-secondary-partition - ;; listen-secondary-partition : (partition<%> -> void) -> void - listen-secondary-partition + ;; listen-secondary-partition : (partition<%> -> void) -> void + listen-secondary-partition - ;; get-identifier=? : -> (cons string procedure) - get-identifier=? + ;; get-identifier=? : -> (cons string procedure) + get-identifier=? - ;; set-identifier=? : (cons string procedure) -> void - set-identifier=? + ;; set-identifier=? : (cons string procedure) -> void + set-identifier=? - ;; listen-identifier=? : ((cons string procedure) -> void) -> void - listen-identifier=?)) + ;; listen-identifier=? : ((cons string procedure) -> void) -> void + listen-identifier=?)) - ;; controller<%> - (define controller<%> - (interface (displays-manager<%> - selection-manager<%> - mark-manager<%> - secondary-partition<%>))) +;; controller<%> +(define controller<%> + (interface (displays-manager<%> + selection-manager<%> + mark-manager<%> + secondary-partition<%>))) - ;; host<%> - (define host<%> - (interface () - ;; get-controller : -> controller<%> - get-controller +;; host<%> +(define host<%> + (interface () + ;; get-controller : -> controller<%> + get-controller - ;; add-keymap : text snip - add-keymap - )) + ;; add-keymap : text snip + add-keymap + )) - ;; display<%> - (define display<%> - (interface () - ;; refresh : -> void - refresh +;; display<%> +(define display<%> + (interface () + ;; refresh : -> void + refresh - ;; highlight-syntaxes : (list-of syntax) color -> void - highlight-syntaxes + ;; highlight-syntaxes : (list-of syntax) color -> void + highlight-syntaxes - ;; get-start-position : -> number - get-start-position + ;; get-start-position : -> number + get-start-position - ;; get-end-position : -> number - get-end-position + ;; get-end-position : -> number + get-end-position - ;; get-range : -> range<%> - get-range)) + ;; get-range : -> range<%> + get-range)) - ;; range<%> - (define range<%> - (interface () - ;; get-ranges : datum -> (list-of (cons number number)) - get-ranges +;; range<%> +(define range<%> + (interface () + ;; get-ranges : datum -> (list-of (cons number number)) + get-ranges - ;; all-ranges : (list-of Range) - ;; Sorted outermost-first - all-ranges + ;; all-ranges : (list-of Range) + ;; Sorted outermost-first + all-ranges - ;; get-identifier-list : (list-of identifier) - get-identifier-list)) + ;; get-identifier-list : (list-of identifier) + get-identifier-list)) - ;; A Range is (make-range datum number number) - (define-struct range (obj start end)) +;; A Range is (make-range datum number number) +(define-struct range (obj start end)) - ;; syntax-prefs<%> - (define syntax-prefs<%> - (interface () - pref:width - pref:height - pref:props-percentage - pref:props-shown?)) +;; syntax-prefs<%> +(define syntax-prefs<%> + (interface () + pref:width + pref:height + pref:props-percentage + pref:props-shown?)) - ;; widget-hooks<%> - (define widget-hooks<%> - (interface () - ;; setup-keymap : -> void - setup-keymap +;; widget-hooks<%> +(define widget-hooks<%> + (interface () + ;; setup-keymap : -> void + setup-keymap - ;; shutdown : -> void - shutdown - )) + ;; shutdown : -> void + shutdown + )) - ;; keymap-hooks<%> - (define keymap-hooks<%> - (interface () - ;; make-context-menu : -> context-menu<%> - make-context-menu +;; keymap-hooks<%> +(define keymap-hooks<%> + (interface () + ;; make-context-menu : -> context-menu<%> + make-context-menu - ;; get-context-menu% : -> class - get-context-menu%)) + ;; get-context-menu% : -> class + get-context-menu%)) - ;; context-menu-hooks<%> - (define context-menu-hooks<%> - (interface () - add-edit-items - after-edit-items - add-selection-items - after-selection-items - add-partition-items - after-partition-items)) +;; context-menu-hooks<%> +(define context-menu-hooks<%> + (interface () + add-edit-items + after-edit-items + add-selection-items + after-selection-items + add-partition-items + after-partition-items)) - ;;---------- +;;---------- - ;; Convenience widget, specialized for displaying stx and not much else - (define syntax-browser<%> - (interface () - add-syntax - add-text - add-separator - erase-all - select-syntax - get-text - )) +;; Convenience widget, specialized for displaying stx and not much else +(define syntax-browser<%> + (interface () + add-syntax + add-text + add-separator + erase-all + select-syntax + get-text + )) - (define partition<%> - (interface () - ;; get-partition : any -> number - get-partition +(define partition<%> + (interface () + ;; get-partition : any -> number + get-partition - ;; same-partition? : any any -> number - same-partition? + ;; same-partition? : any any -> number + same-partition? - ;; count : -> number - count)) - - ) + ;; count : -> number + count)) diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss index b32ad3f..b9f1af6 100644 --- a/collects/macro-debugger/syntax-browser/keymap.ss +++ b/collects/macro-debugger/syntax-browser/keymap.ss @@ -1,152 +1,150 @@ -(module keymap mzscheme - (require (lib "class.ss") - (lib "mred.ss" "mred") - "interfaces.ss" - "partition.ss") - (provide syntax-keymap% - context-menu%) +#lang scheme/base +(require scheme/class + scheme/gui + "interfaces.ss" + "partition.ss") +(provide syntax-keymap% + context-menu%) - (define syntax-keymap% - (class keymap% - (init editor) - (init-field controller) +(define syntax-keymap% + (class keymap% + (init editor) + (init-field controller) - (inherit add-function - map-function - chain-to-keymap) - (super-new) + (inherit add-function + map-function + chain-to-keymap) + (super-new) - (define/public (get-context-menu%) - context-menu%) + (define/public (get-context-menu%) + context-menu%) - (define/public (make-context-menu) - (new (get-context-menu%) (controller controller) (keymap this))) + (define/public (make-context-menu) + (new (get-context-menu%) (controller controller) (keymap this))) - ;; Key mappings + ;; Key mappings - (map-function "rightbutton" "popup-context-window") + (map-function "rightbutton" "popup-context-window") - ;; Functionality + ;; Functionality - (add-function "popup-context-window" - (lambda (editor event) - (do-popup-context-window editor event))) + (add-function "popup-context-window" + (lambda (editor event) + (do-popup-context-window editor event))) - (add-function "copy-text" - (lambda (_ event) - (define stx (send controller get-selected-syntax)) - (send the-clipboard set-clipboard-string - (if stx - (format "~s" (syntax-object->datum stx)) - "") - (send event get-time-stamp)))) + (add-function "copy-text" + (lambda (_ event) + (define stx (send controller get-selected-syntax)) + (send the-clipboard set-clipboard-string + (if stx + (format "~s" (syntax->datum stx)) + "") + (send event get-time-stamp)))) - (add-function "clear-syntax-selection" - (lambda (i e) - (send controller set-selected-syntax #f))) + (add-function "clear-syntax-selection" + (lambda (i e) + (send controller set-selected-syntax #f))) - (add-function "show-syntax-properties" - (lambda (i e) - (error 'show-syntax-properties "not provided by this keymap"))) + (add-function "show-syntax-properties" + (lambda (i e) + (error 'show-syntax-properties "not provided by this keymap"))) - ;; Attach to editor + ;; Attach to editor - (chain-to-keymap (send editor get-keymap) #t) - (send editor set-keymap this) + (chain-to-keymap (send editor get-keymap) #t) + (send editor set-keymap this) - (define/public (get-controller) controller) + (define/public (get-controller) controller) - (define/private (do-popup-context-window editor event) - (define-values (x y) - (send editor dc-location-to-editor-location - (send event get-x) - (send event get-y))) - (define admin (send editor get-admin)) - (send admin popup-menu (make-context-menu) x y)))) + (define/private (do-popup-context-window editor event) + (define-values (x y) + (send editor dc-location-to-editor-location + (send event get-x) + (send event get-y))) + (define admin (send editor get-admin)) + (send admin popup-menu (make-context-menu) x y)))) - (define context-menu% - (class popup-menu% - (init-field keymap) - (init-field controller) - (super-new) +(define context-menu% + (class popup-menu% + (init-field keymap) + (init-field controller) + (super-new) - (field [copy-menu #f] - [clear-menu #f] - [props-menu #f]) + (field [copy-menu #f] + [clear-menu #f] + [props-menu #f]) - (define/public (add-edit-items) - (set! copy-menu - (new menu-item% (label "Copy") (parent this) - (callback (lambda (i e) - (send keymap call-function "copy-text" i e))))) - (void)) + (define/public (add-edit-items) + (set! copy-menu + (new menu-item% (label "Copy") (parent this) + (callback (lambda (i e) + (send keymap call-function "copy-text" i e))))) + (void)) - (define/public (after-edit-items) - (void)) + (define/public (after-edit-items) + (void)) - (define/public (add-selection-items) - (set! clear-menu - (new menu-item% - (label "Clear selection") - (parent this) - (callback - (lambda (i e) - (send keymap call-function "clear-syntax-selection" i e))))) - (set! props-menu - (new menu-item% - (label "Show syntax properties") - (parent this) - (callback - (lambda (i e) - (send keymap call-function "show-syntax-properties" i e))))) - (void)) + (define/public (add-selection-items) + (set! clear-menu + (new menu-item% + (label "Clear selection") + (parent this) + (callback + (lambda (i e) + (send keymap call-function "clear-syntax-selection" i e))))) + (set! props-menu + (new menu-item% + (label "Show syntax properties") + (parent this) + (callback + (lambda (i e) + (send keymap call-function "show-syntax-properties" i e))))) + (void)) - (define/public (after-selection-items) - (void)) + (define/public (after-selection-items) + (void)) - (define/public (add-partition-items) - (let ([secondary (new menu% (label "identifier=?") (parent this))]) - (for-each - (lambda (name func) - (let ([this-choice - (new checkable-menu-item% - (label name) - (parent secondary) - (callback - (lambda (i e) - (send controller set-identifier=? - (cons name func)))))]) - (send controller listen-identifier=? - (lambda (name+proc) - (send this-choice check (eq? name (car name+proc))))))) - (map car (identifier=-choices)) - (map cdr (identifier=-choices)))) - (void)) + (define/public (add-partition-items) + (let ([secondary (new menu% (label "identifier=?") (parent this))]) + (for-each + (lambda (name func) + (let ([this-choice + (new checkable-menu-item% + (label name) + (parent secondary) + (callback + (lambda (i e) + (send controller set-identifier=? + (cons name func)))))]) + (send controller listen-identifier=? + (lambda (name+proc) + (send this-choice check (eq? name (car name+proc))))))) + (map car (identifier=-choices)) + (map cdr (identifier=-choices)))) + (void)) - (define/public (after-partition-items) - (void)) + (define/public (after-partition-items) + (void)) - (define/public (add-separator) - (new separator-menu-item% (parent this))) + (define/public (add-separator) + (new separator-menu-item% (parent this))) - (define/override (on-demand) - (define stx (send controller get-selected-syntax)) - (send copy-menu enable (and stx #t)) - (send clear-menu enable (and stx #t)) - (super on-demand)) + (define/override (on-demand) + (define stx (send controller get-selected-syntax)) + (send copy-menu enable (and stx #t)) + (send clear-menu enable (and stx #t)) + (super on-demand)) - ;; Initialization - (add-edit-items) - (after-edit-items) + ;; Initialization + (add-edit-items) + (after-edit-items) - (add-separator) - (add-selection-items) - (after-selection-items) + (add-separator) + (add-selection-items) + (after-selection-items) - (add-separator) - (add-partition-items) - (after-partition-items) - )) - - ) + (add-separator) + (add-partition-items) + (after-partition-items) + )) diff --git a/collects/macro-debugger/syntax-browser/partition.ss b/collects/macro-debugger/syntax-browser/partition.ss index cafd426..9c62aa8 100644 --- a/collects/macro-debugger/syntax-browser/partition.ss +++ b/collects/macro-debugger/syntax-browser/partition.ss @@ -1,159 +1,157 @@ -(module partition mzscheme - (require (lib "class.ss") - (lib "boundmap.ss" "syntax") - (lib "stx.ss" "syntax") - "interfaces.ss") - (provide new-bound-partition - partition% - identifier=-choices) - - (define (new-bound-partition) - (new bound-partition%)) - - ;; representative-symbol : symbol - ;; Must be fresh---otherwise, using it could detect rename wraps - ;; instead of only marks. - ;; For example, in (lambda (representative) representative) - (define representative-symbol - (gensym 'representative)) +#lang scheme/base +(require scheme/class + syntax/boundmap + syntax/stx + "interfaces.ss") +(provide new-bound-partition + partition% + identifier=-choices) - ;; unmarked-syntax : identifier - ;; Has no marks---used to initialize bound partition so that - ;; unmarked syntax always gets colored "black" - (define unmarked-syntax - (datum->syntax-object #f representative-symbol)) - - (define partition% - (class* object% (partition<%>) - (init relation) +(define (new-bound-partition) + (new bound-partition%)) - (define related? (or relation (lambda (a b) #f))) - (field (rep=>num (make-hash-table))) - (field (obj=>rep (make-hash-table 'weak))) - (field (reps null)) - (field (next-num 0)) - - (define/public (get-partition obj) - (rep->partition (obj->rep obj))) +;; representative-symbol : symbol +;; Must be fresh---otherwise, using it could detect rename wraps +;; instead of only marks. +;; For example, in (lambda (representative) representative) +(define representative-symbol + (gensym 'representative)) - (define/public (same-partition? A B) - (= (get-partition A) (get-partition B))) - - (define/private (obj->rep obj) - (hash-table-get obj=>rep obj (lambda () (obj->rep* obj)))) - - (define/public (count) - next-num) +;; unmarked-syntax : identifier +;; Has no marks---used to initialize bound partition so that +;; unmarked syntax always gets colored "black" +(define unmarked-syntax + (datum->syntax #f representative-symbol)) - (define/private (obj->rep* obj) - (let loop ([reps reps]) - (cond [(null? reps) - (new-rep obj)] - [(related? obj (car reps)) - (hash-table-put! obj=>rep obj (car reps)) - (car reps)] - [else - (loop (cdr reps))]))) +(define partition% + (class* object% (partition<%>) + (init relation) - (define/private (new-rep rep) - (hash-table-put! rep=>num rep next-num) - (set! next-num (add1 next-num)) - (set! reps (cons rep reps)) - rep) - - (define/private (rep->partition rep) - (hash-table-get rep=>num rep)) + (define related? (or relation (lambda (a b) #f))) + (field (rep=>num (make-hash-table))) + (field (obj=>rep (make-hash-table 'weak))) + (field (reps null)) + (field (next-num 0)) + + (define/public (get-partition obj) + (rep->partition (obj->rep obj))) - ;; Nearly useless as it stands - (define/public (dump) - (hash-table-for-each - rep=>num - (lambda (k v) - (printf "~s => ~s~n" k v)))) + (define/public (same-partition? A B) + (= (get-partition A) (get-partition B))) + + (define/private (obj->rep obj) + (hash-table-get obj=>rep obj (lambda () (obj->rep* obj)))) + + (define/public (count) + next-num) - (get-partition unmarked-syntax) - (super-new) - )) - - ;; bound-partition% - (define bound-partition% - (class* object% (partition<%>) - ;; numbers : bound-identifier-mapping[identifier => number] - (define numbers (make-bound-identifier-mapping)) - (define next-number 0) - - (define/public (get-partition stx) - (let* ([r (representative stx)] - [n (bound-identifier-mapping-get numbers r (lambda _ #f))]) - (or n - (begin0 next-number - (bound-identifier-mapping-put! numbers r next-number) - #;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax-object->datum stx)) - (set! next-number (add1 next-number)))))) - - (define/public (same-partition? a b) - (= (get-partition a) (get-partition b))) - - (define/public (count) - next-number) - - (define/private (representative stx) - (datum->syntax-object stx representative-symbol)) + (define/private (obj->rep* obj) + (let loop ([reps reps]) + (cond [(null? reps) + (new-rep obj)] + [(related? obj (car reps)) + (hash-table-put! obj=>rep obj (car reps)) + (car reps)] + [else + (loop (cdr reps))]))) - (get-partition unmarked-syntax) - (super-new))) - - ;; Different identifier relations for highlighting. + (define/private (new-rep rep) + (hash-table-put! rep=>num rep next-num) + (set! next-num (add1 next-num)) + (set! reps (cons rep reps)) + rep) + + (define/private (rep->partition rep) + (hash-table-get rep=>num rep)) - (define (lift/rep id=?) - (lambda (A B) - (let ([ra (datum->syntax-object A representative-symbol)] - [rb (datum->syntax-object B representative-symbol)]) - (id=? ra rb)))) - - (define (lift id=?) - (lambda (A B) - (and (identifier? A) (identifier? B) (id=? A B)))) - - ;; id:same-marks? : syntax syntax -> boolean - (define id:same-marks? - (lift/rep bound-identifier=?)) + ;; Nearly useless as it stands + (define/public (dump) + (hash-table-for-each + rep=>num + (lambda (k v) + (printf "~s => ~s~n" k v)))) - ;; id:X-module=? : identifier identifier -> boolean - ;; If both module-imported, do they come from the same module? - ;; If both top-bound, then same source. - (define (id:source-module=? a b) - (let ([ba (identifier-binding a)] - [bb (identifier-binding b)]) - (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) - (module-identifier=? a b)] - [(and (not ba) (not bb)) - #t] - [(or (not ba) (not bb)) - #f] - [else - (eq? (car ba) (car bb))]))) - (define (id:nominal-module=? A B) - (let ([ba (identifier-binding A)] - [bb (identifier-binding B)]) - (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) - (module-identifier=? A B)] - [(or (not ba) (not bb)) - (and (not ba) (not bb))] - [else (eq? (caddr ba) (caddr bb))]))) - - (define (symbolic-identifier=? A B) - (eq? (syntax-e A) (syntax-e B))) + (get-partition unmarked-syntax) + (super-new) + )) - (define identifier=-choices - (make-parameter - `(("" . #f) - ("bound-identifier=?" . ,bound-identifier=?) - ("module-identifier=?" . ,module-identifier=?) - ("module-or-top-identifier=?" . ,module-or-top-identifier=?) - ("symbolic-identifier=?" . ,symbolic-identifier=?) - ("same source module" . ,id:source-module=?) - ("same nominal module" . ,id:nominal-module=?)))) - - ) \ No newline at end of file +;; bound-partition% +(define bound-partition% + (class* object% (partition<%>) + ;; numbers : bound-identifier-mapping[identifier => number] + (define numbers (make-bound-identifier-mapping)) + (define next-number 0) + + (define/public (get-partition stx) + (let* ([r (representative stx)] + [n (bound-identifier-mapping-get numbers r (lambda _ #f))]) + (or n + (begin0 next-number + (bound-identifier-mapping-put! numbers r next-number) + #;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax->datum stx)) + (set! next-number (add1 next-number)))))) + + (define/public (same-partition? a b) + (= (get-partition a) (get-partition b))) + + (define/public (count) + next-number) + + (define/private (representative stx) + (datum->syntax stx representative-symbol)) + + (get-partition unmarked-syntax) + (super-new))) + +;; Different identifier relations for highlighting. + +(define (lift/rep id=?) + (lambda (A B) + (let ([ra (datum->syntax A representative-symbol)] + [rb (datum->syntax B representative-symbol)]) + (id=? ra rb)))) + +(define (lift id=?) + (lambda (A B) + (and (identifier? A) (identifier? B) (id=? A B)))) + +;; id:same-marks? : syntax syntax -> boolean +(define id:same-marks? + (lift/rep bound-identifier=?)) + +;; id:X-module=? : identifier identifier -> boolean +;; If both module-imported, do they come from the same module? +;; If both top-bound, then same source. +(define (id:source-module=? a b) + (let ([ba (identifier-binding a)] + [bb (identifier-binding b)]) + (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) + (free-identifier=? a b)] + [(and (not ba) (not bb)) + #t] + [(or (not ba) (not bb)) + #f] + [else + (eq? (car ba) (car bb))]))) +(define (id:nominal-module=? A B) + (let ([ba (identifier-binding A)] + [bb (identifier-binding B)]) + (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) + (free-identifier=? A B)] + [(or (not ba) (not bb)) + (and (not ba) (not bb))] + [else (eq? (caddr ba) (caddr bb))]))) + +(define (symbolic-identifier=? A B) + (eq? (syntax-e A) (syntax-e B))) + +(define identifier=-choices + (make-parameter + `(("" . #f) + ("bound-identifier=?" . ,bound-identifier=?) + ("free-identifier=?" . ,free-identifier=?) + ("module-or-top-identifier=?" . ,module-or-top-identifier=?) + ("symbolic-identifier=?" . ,symbolic-identifier=?) + ("same source module" . ,id:source-module=?) + ("same nominal module" . ,id:nominal-module=?)))) diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 7366a9e..6777899 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -1,32 +1,31 @@ -(module prefs mzscheme - (require (lib "class.ss") - (lib "framework.ss" "framework") - "interfaces.ss" - "../util/misc.ss") - (provide syntax-prefs% - syntax-prefs-mixin +#lang scheme/base +(require scheme/class + framework/framework + "interfaces.ss" + "../util/misc.ss") +(provide syntax-prefs% + syntax-prefs-mixin - pref:tabify) + pref:tabify) - (preferences:set-default 'SyntaxBrowser:Width 700 number?) - (preferences:set-default 'SyntaxBrowser:Height 600 number?) - (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) - (preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?) +(preferences:set-default 'SyntaxBrowser:Width 700 number?) +(preferences:set-default 'SyntaxBrowser:Height 600 number?) +(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) +(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?) - (pref:get/set pref:width SyntaxBrowser:Width) - (pref:get/set pref:height SyntaxBrowser:Height) - (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) - (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) +(pref:get/set pref:width SyntaxBrowser:Width) +(pref:get/set pref:height SyntaxBrowser:Height) +(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) +(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) - (pref:get/set pref:tabify framework:tabify) +(pref:get/set pref:tabify framework:tabify) - (define syntax-prefs-mixin - (closure-mixin (syntax-prefs<%>) - (pref:width pref:width) - (pref:height pref:height) - (pref:props-percentage pref:props-percentage) - (pref:props-shown? pref:props-shown?))) +(define syntax-prefs-mixin + (closure-mixin (syntax-prefs<%>) + (pref:width pref:width) + (pref:height pref:height) + (pref:props-percentage pref:props-percentage) + (pref:props-shown? pref:props-shown?))) - (define syntax-prefs% (syntax-prefs-mixin object%)) - ) +(define syntax-prefs% (syntax-prefs-mixin object%)) diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index 1353a0b..73bb361 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -1,150 +1,148 @@ -(module pretty-helper mzscheme - (require (lib "class.ss") - (lib "stx.ss" "syntax") - "partition.ss") - (provide (all-defined)) +#lang scheme/base +(require scheme/class + syntax/stx + "partition.ss") +(provide (all-defined-out)) - ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it - ;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are - ;; indistinguishable. +;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it +;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are +;; indistinguishable. - ;; Solution: Rather than map stx to (syntax-e stx), in the cases where - ;; (syntax-e stx) is confusable, map it to a different, unique, value. - ;; - stx is identifier : map it to an uninterned symbol w/ same rep - ;; (Symbols are useful: see pretty-print's style table) - ;; - else : map it to a syntax-dummy object +;; Solution: Rather than map stx to (syntax-e stx), in the cases where +;; (syntax-e stx) is confusable, map it to a different, unique, value. +;; - stx is identifier : map it to an uninterned symbol w/ same rep +;; (Symbols are useful: see pretty-print's style table) +;; - else : map it to a syntax-dummy object - ;; NOTE: Nulls are only wrapped when *not* list-terminators. - ;; If they were always wrapped, the pretty-printer would screw up - ;; list printing (I think). +;; NOTE: Nulls are only wrapped when *not* list-terminators. +;; If they were always wrapped, the pretty-printer would screw up +;; list printing (I think). - (define-struct syntax-dummy (val)) +(define-struct syntax-dummy (val)) - ;; A SuffixOption is one of - ;; - 'never -- never - ;; - 'always -- suffix > 0 - ;; - 'over-limit -- suffix > limit - ;; - 'all-if-over-limit -- suffix > 0 if any over limit +;; A SuffixOption is one of +;; - 'never -- never +;; - 'always -- suffix > 0 +;; - 'over-limit -- suffix > limit +;; - 'all-if-over-limit -- suffix > 0 if any over limit - ;; syntax->datum/tables : stx [partition% num SuffixOption] - ;; -> (values s-expr hashtable hashtable) - ;; When partition is not false, tracks the partititions that subterms belong to - ;; When limit is a number, restarts processing with numbering? set to true - ;; - ;; Returns three values: - ;; - an S-expression - ;; - a hashtable mapping S-expressions to syntax objects - ;; - a hashtable mapping syntax objects to S-expressions - ;; Syntax objects which are eq? will map to same flat values - (define syntax->datum/tables - (case-lambda - [(stx) (table stx #f #f 'never)] - [(stx partition limit suffixopt) (table stx partition limit suffixopt)])) +;; syntax->datum/tables : stx [partition% num SuffixOption] +;; -> (values s-expr hashtable hashtable) +;; When partition is not false, tracks the partititions that subterms belong to +;; When limit is a number, restarts processing with numbering? set to true +;; +;; Returns three values: +;; - an S-expression +;; - a hashtable mapping S-expressions to syntax objects +;; - a hashtable mapping syntax objects to S-expressions +;; Syntax objects which are eq? will map to same flat values +(define syntax->datum/tables + (case-lambda + [(stx) (table stx #f #f 'never)] + [(stx partition limit suffixopt) (table stx partition limit suffixopt)])) - ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) - (define (table stx partition limit suffixopt) - (define (make-identifier-proxy id) - (case suffixopt - ((never) (unintern (syntax-e id))) - ((always) - (let ([n (send partition get-partition id)]) - (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n)))) - ((over-limit) - (let ([n (send partition get-partition id)]) - (if (<= n limit) - (unintern (syntax-e id)) - (suffix (syntax-e id) n)))))) +;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) +(define (table stx partition limit suffixopt) + (define (make-identifier-proxy id) + (case suffixopt + ((never) (unintern (syntax-e id))) + ((always) + (let ([n (send partition get-partition id)]) + (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n)))) + ((over-limit) + (let ([n (send partition get-partition id)]) + (if (<= n limit) + (unintern (syntax-e id)) + (suffix (syntax-e id) n)))))) - (let/ec escape - (let ([flat=>stx (make-hash-table)] - [stx=>flat (make-hash-table)]) - (define (loop obj) - (cond [(hash-table-get stx=>flat obj (lambda _ #f)) - => (lambda (datum) datum)] - [(and partition (identifier? obj)) - (when (and (eq? suffixopt 'all-if-over-limit) - (> (send partition count) limit)) - (call-with-values (lambda () (table stx partition #f 'always)) - escape)) - (let ([lp-datum (make-identifier-proxy obj)]) - (hash-table-put! flat=>stx lp-datum obj) - (hash-table-put! stx=>flat obj lp-datum) - lp-datum)] - [(and (syntax? obj) (check+convert-special-expression obj)) - => (lambda (newobj) - (when partition (send partition get-partition obj)) - (let* ([inner (cadr newobj)] - [lp-inner-datum (loop inner)] - [lp-datum (list (car newobj) lp-inner-datum)]) - (hash-table-put! flat=>stx lp-inner-datum inner) - (hash-table-put! stx=>flat inner lp-inner-datum) - (hash-table-put! flat=>stx lp-datum obj) - (hash-table-put! stx=>flat obj lp-datum) - lp-datum))] - [(syntax? obj) - (when partition (send partition get-partition obj)) - (let ([lp-datum (loop (syntax-e obj))]) - (hash-table-put! flat=>stx lp-datum obj) - (hash-table-put! stx=>flat obj lp-datum) - lp-datum)] - [(pair? obj) - (pairloop obj)] - [(symbol? obj) - (unintern obj)] - [(null? obj) - (make-syntax-dummy obj)] - [(boolean? obj) - (make-syntax-dummy obj)] - [(number? obj) - (make-syntax-dummy obj)] - [(keyword? obj) - (make-syntax-dummy obj)] - [(vector? obj) - (list->vector (map loop (vector->list obj)))] - [(box? obj) - (box (loop (unbox obj)))] - [else obj])) - (define (pairloop obj) - (cond [(pair? obj) - (cons (loop (car obj)) - (pairloop (cdr obj)))] - [(null? obj) - null] - [(and (syntax? obj) (null? (syntax-e obj))) - null] - [else (loop obj)])) - (values (loop stx) - flat=>stx - stx=>flat)))) + (let/ec escape + (let ([flat=>stx (make-hash-table)] + [stx=>flat (make-hash-table)]) + (define (loop obj) + (cond [(hash-table-get stx=>flat obj (lambda _ #f)) + => (lambda (datum) datum)] + [(and partition (identifier? obj)) + (when (and (eq? suffixopt 'all-if-over-limit) + (> (send partition count) limit)) + (call-with-values (lambda () (table stx partition #f 'always)) + escape)) + (let ([lp-datum (make-identifier-proxy obj)]) + (hash-table-put! flat=>stx lp-datum obj) + (hash-table-put! stx=>flat obj lp-datum) + lp-datum)] + [(and (syntax? obj) (check+convert-special-expression obj)) + => (lambda (newobj) + (when partition (send partition get-partition obj)) + (let* ([inner (cadr newobj)] + [lp-inner-datum (loop inner)] + [lp-datum (list (car newobj) lp-inner-datum)]) + (hash-table-put! flat=>stx lp-inner-datum inner) + (hash-table-put! stx=>flat inner lp-inner-datum) + (hash-table-put! flat=>stx lp-datum obj) + (hash-table-put! stx=>flat obj lp-datum) + lp-datum))] + [(syntax? obj) + (when partition (send partition get-partition obj)) + (let ([lp-datum (loop (syntax-e obj))]) + (hash-table-put! flat=>stx lp-datum obj) + (hash-table-put! stx=>flat obj lp-datum) + lp-datum)] + [(pair? obj) + (pairloop obj)] + [(symbol? obj) + (unintern obj)] + [(null? obj) + (make-syntax-dummy obj)] + [(boolean? obj) + (make-syntax-dummy obj)] + [(number? obj) + (make-syntax-dummy obj)] + [(keyword? obj) + (make-syntax-dummy obj)] + [(vector? obj) + (list->vector (map loop (vector->list obj)))] + [(box? obj) + (box (loop (unbox obj)))] + [else obj])) + (define (pairloop obj) + (cond [(pair? obj) + (cons (loop (car obj)) + (pairloop (cdr obj)))] + [(null? obj) + null] + [(and (syntax? obj) (null? (syntax-e obj))) + null] + [else (loop obj)])) + (values (loop stx) + flat=>stx + stx=>flat)))) - ;; check+convert-special-expression : syntax -> #f/syntaxish - (define (check+convert-special-expression stx) - (define stx-list (stx->list stx)) - (and stx-list (= 2 (length stx-list)) - (let ([kw (car stx-list)] - [expr (cadr stx-list)]) - (and (identifier? kw) - (memq (syntax-e kw) special-expression-keywords) - (bound-identifier=? kw (datum->syntax-object stx (syntax-e kw))) - (andmap (lambda (f) (equal? (f stx) (f kw))) - (list syntax-source - syntax-line - syntax-column - syntax-position - syntax-original? - syntax-source-module)) - (cons (syntax-e kw) - (list expr)))))) +;; check+convert-special-expression : syntax -> #f/syntaxish +(define (check+convert-special-expression stx) + (define stx-list (stx->list stx)) + (and stx-list (= 2 (length stx-list)) + (let ([kw (car stx-list)] + [expr (cadr stx-list)]) + (and (identifier? kw) + (memq (syntax-e kw) special-expression-keywords) + (bound-identifier=? kw (datum->syntax stx (syntax-e kw))) + (andmap (lambda (f) (equal? (f stx) (f kw))) + (list syntax-source + syntax-line + syntax-column + syntax-position + syntax-original? + syntax-source-module)) + (cons (syntax-e kw) + (list expr)))))) - (define special-expression-keywords - '(quote quasiquote unquote unquote-splicing syntax)) - ;; FIXME: quasisyntax unsyntax unsyntax-splicing +(define special-expression-keywords + '(quote quasiquote unquote unquote-splicing syntax)) +;; FIXME: quasisyntax unsyntax unsyntax-splicing - (define (unintern sym) - (string->uninterned-symbol (symbol->string sym))) +(define (unintern sym) + (string->uninterned-symbol (symbol->string sym))) - (define (suffix sym n) - (string->uninterned-symbol (format "~a:~a" sym n))) - - ) +(define (suffix sym n) + (string->uninterned-symbol (format "~a:~a" sym n))) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index 95e57b1..8731b22 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -1,161 +1,160 @@ ;; FIXME: Need to disable printing of structs with custom-write property -(module pretty-printer mzscheme - (require (lib "list.ss") - (lib "class.ss") - (lib "pretty.ss") - (lib "mred.ss" "mred") - "pretty-helper.ss" - "interfaces.ss" - "params.ss" - "prefs.ss") +#lang scheme/base +(require scheme/list + scheme/class + scheme/pretty + scheme/gui + "pretty-helper.ss" + "interfaces.ss" + "params.ss" + "prefs.ss") - (provide pretty-print-syntax) +(provide pretty-print-syntax) - ;; pretty-print-syntax : syntax port partition -> range% - (define (pretty-print-syntax stx port primary-partition) - (define range-builder (new range-builder%)) - (define-values (datum ht:flat=>stx ht:stx=>flat) - (syntax->datum/tables stx primary-partition - (length (current-colors)) - (current-suffix-option))) - (define identifier-list - (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))) - (define (flat=>stx obj) - (hash-table-get ht:flat=>stx obj #f)) - (define (stx=>flat stx) - (hash-table-get ht:stx=>flat stx)) - (define (current-position) - (let-values ([(line column position) (port-next-location port)]) - (sub1 position))) - (define (pp-pre-hook obj port) - (send range-builder set-start obj (current-position))) - (define (pp-post-hook obj port) - (let ([start (send range-builder get-start obj)] - [end (current-position)] - [stx (flat=>stx obj)]) - (when (and start stx) - (send range-builder add-range stx (cons start end))))) - (define (pp-extend-style-table identifier-list) - (let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)] - [like-syms (map syntax-e identifier-list)]) - (pretty-print-extend-style-table (pp-better-style-table) - syms - like-syms))) +;; pretty-print-syntax : syntax port partition -> range% +(define (pretty-print-syntax stx port primary-partition) + (define range-builder (new range-builder%)) + (define-values (datum ht:flat=>stx ht:stx=>flat) + (syntax->datum/tables stx primary-partition + (length (current-colors)) + (current-suffix-option))) + (define identifier-list + (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))) + (define (flat=>stx obj) + (hash-table-get ht:flat=>stx obj #f)) + (define (stx=>flat stx) + (hash-table-get ht:stx=>flat stx)) + (define (current-position) + (let-values ([(line column position) (port-next-location port)]) + (sub1 position))) + (define (pp-pre-hook obj port) + (send range-builder set-start obj (current-position))) + (define (pp-post-hook obj port) + (let ([start (send range-builder get-start obj)] + [end (current-position)] + [stx (flat=>stx obj)]) + (when (and start stx) + (send range-builder add-range stx (cons start end))))) + (define (pp-extend-style-table identifier-list) + (let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)] + [like-syms (map syntax-e identifier-list)]) + (pretty-print-extend-style-table (pp-better-style-table) + syms + like-syms))) - (unless (syntax? stx) - (raise-type-error 'pretty-print-syntax "syntax" stx)) - (parameterize - ([pretty-print-pre-print-hook pp-pre-hook] - [pretty-print-post-print-hook pp-post-hook] - [pretty-print-size-hook pp-size-hook] - [pretty-print-print-hook pp-print-hook] - [pretty-print-current-style-table (pp-extend-style-table identifier-list)] - [pretty-print-columns (current-default-columns)] - ;; Printing parameters (mzscheme manual 7.9.1.4) - [print-unreadable #t] - [print-graph #f] - [print-struct #f] - [print-box #t] - [print-vector-length #t] - [print-hash-table #f] - [print-honu #f]) - (pretty-print datum port) - (new range% - (range-builder range-builder) - (identifier-list identifier-list)))) + (unless (syntax? stx) + (raise-type-error 'pretty-print-syntax "syntax" stx)) + (parameterize + ([pretty-print-pre-print-hook pp-pre-hook] + [pretty-print-post-print-hook pp-post-hook] + [pretty-print-size-hook pp-size-hook] + [pretty-print-print-hook pp-print-hook] + [pretty-print-current-style-table (pp-extend-style-table identifier-list)] + [pretty-print-columns (current-default-columns)] + ;; Printing parameters (mzscheme manual 7.9.1.4) + [print-unreadable #t] + [print-graph #f] + [print-struct #f] + [print-box #t] + [print-vector-length #t] + [print-hash-table #f] + [print-honu #f]) + (pretty-print datum port) + (new range% + (range-builder range-builder) + (identifier-list identifier-list)))) - (define (pp-print-hook obj display-like? port) - (cond [(syntax-dummy? obj) - ((if display-like? display write) (syntax-dummy-val obj) port)] - [(is-a? obj editor-snip%) - (write-special obj port)] - [else - (error 'pretty-print-hook "unexpected special value: ~e" obj)])) +(define (pp-print-hook obj display-like? port) + (cond [(syntax-dummy? obj) + ((if display-like? display write) (syntax-dummy-val obj) port)] + [(is-a? obj editor-snip%) + (write-special obj port)] + [else + (error 'pretty-print-hook "unexpected special value: ~e" obj)])) - (define (pp-size-hook obj display-like? port) - (cond [(is-a? obj editor-snip%) - (pretty-print-columns)] - [(syntax-dummy? obj) - (let ((ostring (open-output-string))) - ((if display-like? display write) (syntax-dummy-val obj) ostring) - (string-length (get-output-string ostring)))] - [else #f])) +(define (pp-size-hook obj display-like? port) + (cond [(is-a? obj editor-snip%) + (pretty-print-columns)] + [(syntax-dummy? obj) + (let ((ostring (open-output-string))) + ((if display-like? display write) (syntax-dummy-val obj) ostring) + (string-length (get-output-string ostring)))] + [else #f])) - (define (pp-better-style-table) - (let* ([pref (pref:tabify)] - [table (car pref)] - [begin-rx (cadr pref)] - [define-rx (caddr pref)] - [lambda-rx (cadddr pref)]) - (let ([style-list (hash-table-map table cons)]) - (pretty-print-extend-style-table - (basic-style-list) - (map car style-list) - (map cdr style-list))))) +(define (pp-better-style-table) + (let* ([pref (pref:tabify)] + [table (car pref)] + [begin-rx (cadr pref)] + [define-rx (caddr pref)] + [lambda-rx (cadddr pref)]) + (let ([style-list (hash-table-map table cons)]) + (pretty-print-extend-style-table + (basic-style-list) + (map car style-list) + (map cdr style-list))))) - (define (basic-style-list) - (pretty-print-extend-style-table - (pretty-print-current-style-table) - (map car basic-styles) - (map cdr basic-styles))) - (define basic-styles - '((define-values . define) - (define-syntaxes . define-syntax))) +(define (basic-style-list) + (pretty-print-extend-style-table + (pretty-print-current-style-table) + (map car basic-styles) + (map cdr basic-styles))) +(define basic-styles + '((define-values . define) + (define-syntaxes . define-syntax))) - (define-local-member-name range:get-ranges) +(define-local-member-name range:get-ranges) - ;; range-builder% - (define range-builder% - (class object% - (define starts (make-hash-table)) - (define ranges (make-hash-table)) +;; range-builder% +(define range-builder% + (class object% + (define starts (make-hash-table)) + (define ranges (make-hash-table)) - (define/public (set-start obj n) - (hash-table-put! starts obj n)) + (define/public (set-start obj n) + (hash-table-put! starts obj n)) - (define/public (get-start obj) - (hash-table-get starts obj (lambda _ #f))) + (define/public (get-start obj) + (hash-table-get starts obj (lambda _ #f))) - (define/public (add-range obj range) - (hash-table-put! ranges obj (cons range (get-ranges obj)))) + (define/public (add-range obj range) + (hash-table-put! ranges obj (cons range (get-ranges obj)))) - (define (get-ranges obj) - (hash-table-get ranges obj (lambda () null))) + (define (get-ranges obj) + (hash-table-get ranges obj (lambda () null))) - (define/public (range:get-ranges) ranges) + (define/public (range:get-ranges) ranges) - (super-new))) + (super-new))) - ;; range% - (define range% - (class* object% (range<%>) - (init range-builder) - (init-field identifier-list) - (super-new) +;; range% +(define range% + (class* object% (range<%>) + (init range-builder) + (init-field identifier-list) + (super-new) - (define ranges (hash-table-copy (send range-builder range:get-ranges))) + (define ranges (hash-table-copy (send range-builder range:get-ranges))) - (define/public (get-ranges obj) - (hash-table-get ranges obj (lambda _ null))) + (define/public (get-ranges obj) + (hash-table-get ranges obj (lambda _ null))) - (define/public (all-ranges) - sorted-ranges) + (define/public (all-ranges) + sorted-ranges) - (define/public (get-identifier-list) - identifier-list) + (define/public (get-identifier-list) + identifier-list) - (define sorted-ranges - (sort - (apply append - (hash-table-map - ranges - (lambda (k vs) - (map (lambda (v) (make-range k (car v) (cdr v))) vs)))) - (lambda (x y) - (>= (- (range-end x) (range-start x)) - (- (range-end y) (range-start y)))))))) + (define sorted-ranges + (sort + (apply append + (hash-table-map + ranges + (lambda (k vs) + (map (lambda (v) (make-range k (car v) (cdr v))) vs)))) + (lambda (x y) + (>= (- (range-end x) (range-start x)) + (- (range-end y) (range-start y)))))))) - ) diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss index ba68b2c..a93fd62 100644 --- a/collects/macro-debugger/syntax-browser/properties.ss +++ b/collects/macro-debugger/syntax-browser/properties.ss @@ -1,314 +1,311 @@ -(module properties mzscheme - (require "interfaces.ss" - "util.ss" - (lib "class.ss") - (lib "mred.ss" "mred") - #;(lib "framework.ss" "framework") - #;(lib "interactive-value-port.ss" "mrlib")) - (provide properties-view% - properties-snip%) +#lang scheme/base +(require scheme/class + scheme/gui + "interfaces.ss" + "util.ss") +(provide properties-view% + properties-snip%) - ;; properties-view-base-mixin - (define properties-view-base-mixin - (mixin () () - ;; controller : controller<%> - (init-field controller) +;; properties-view-base-mixin +(define properties-view-base-mixin + (mixin () () + ;; controller : controller<%> + (init-field controller) - ;; selected-syntax : syntax - (field (selected-syntax #f)) + ;; selected-syntax : syntax + (field (selected-syntax #f)) - ;; mode : maybe symbol in '(term stxobj) - (define mode 'term) + ;; mode : maybe symbol in '(term stxobj) + (define mode 'term) - ;; text : text% - (field (text (new text%))) - (field (pdisplayer (new properties-displayer% (text text)))) + ;; text : text% + (field (text (new text%))) + (field (pdisplayer (new properties-displayer% (text text)))) - (send controller listen-selected-syntax - (lambda (stx) - (set! selected-syntax stx) - (refresh))) - (super-new) + (send controller listen-selected-syntax + (lambda (stx) + (set! selected-syntax stx) + (refresh))) + (super-new) - ;; get-mode : -> symbol - (define/public (get-mode) mode) + ;; get-mode : -> symbol + (define/public (get-mode) mode) - ;; set-mode : symbol -> void - (define/public (set-mode m) - (set! mode m) - (refresh)) + ;; set-mode : symbol -> void + (define/public (set-mode m) + (set! mode m) + (refresh)) - ;; refresh : -> void - (define/public (refresh) - (send* text - (lock #f) - (begin-edit-sequence) - (erase)) - (if (syntax? selected-syntax) - (refresh/mode mode) - (refresh/mode #f)) - (send* text - (end-edit-sequence) - (lock #t) - (scroll-to-position 0))) + ;; refresh : -> void + (define/public (refresh) + (send* text + (lock #f) + (begin-edit-sequence) + (erase)) + (if (syntax? selected-syntax) + (refresh/mode mode) + (refresh/mode #f)) + (send* text + (end-edit-sequence) + (lock #t) + (scroll-to-position 0))) - ;; refresh/mode : symbol -> void - (define/public (refresh/mode mode) - (case mode - ((term) (send pdisplayer display-meaning-info selected-syntax)) - ((stxobj) (send pdisplayer display-stxobj-info selected-syntax)) - ((#f) (send pdisplayer display-null-info)) - (else (error 'properties-view-base:refresh - "internal error: no such mode: ~s" mode)))) + ;; refresh/mode : symbol -> void + (define/public (refresh/mode mode) + (case mode + ((term) (send pdisplayer display-meaning-info selected-syntax)) + ((stxobj) (send pdisplayer display-stxobj-info selected-syntax)) + ((#f) (send pdisplayer display-null-info)) + (else (error 'properties-view-base:refresh + "internal error: no such mode: ~s" mode)))) - (send text set-styles-sticky #f) - #;(send text hide-caret #t) - (send text lock #t) - (refresh))) + (send text set-styles-sticky #f) + #;(send text hide-caret #t) + (send text lock #t) + (refresh))) - ;; properties-snip% - (define properties-snip% - (class (properties-view-base-mixin editor-snip%) - (inherit-field text) - (inherit-field pdisplayer) - (inherit set-mode) +;; properties-snip% +(define properties-snip% + (class (properties-view-base-mixin editor-snip%) + (inherit-field text) + (inherit-field pdisplayer) + (inherit set-mode) - (define/private outer:insert - (case-lambda - [(obj) - (outer:insert obj style:normal)] - [(text style) - (outer:insert text style #f)] - [(text style clickback) - (let ([start (send outer-text last-position)]) - (send outer-text insert text) - (let ([end (send outer-text last-position)]) - (send outer-text change-style style start end #f) - (when clickback - (send outer-text set-clickback start end clickback))))])) + (define/private outer:insert + (case-lambda + [(obj) + (outer:insert obj style:normal)] + [(text style) + (outer:insert text style #f)] + [(text style clickback) + (let ([start (send outer-text last-position)]) + (send outer-text insert text) + (let ([end (send outer-text last-position)]) + (send outer-text change-style style start end #f) + (when clickback + (send outer-text set-clickback start end clickback))))])) - (define outer-text (new text%)) - (super-new (editor outer-text)) - (outer:insert "Term" style:hyper (lambda _ (set-mode 'term))) - (outer:insert " ") - (outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj))) - (outer:insert "\n") - (outer:insert (new editor-snip% (editor text))) - (send outer-text hide-caret #t) - (send outer-text lock #t))) + (define outer-text (new text%)) + (super-new (editor outer-text)) + (outer:insert "Term" style:hyper (lambda _ (set-mode 'term))) + (outer:insert " ") + (outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj))) + (outer:insert "\n") + (outer:insert (new editor-snip% (editor text))) + (send outer-text hide-caret #t) + (send outer-text lock #t))) - ;; properties-view% - (define properties-view% - (class* (properties-view-base-mixin object%) () - (init parent) - (inherit-field text) - (inherit-field pdisplayer) - (inherit set-mode) +;; properties-view% +(define properties-view% + (class* (properties-view-base-mixin object%) () + (init parent) + (inherit-field text) + (inherit-field pdisplayer) + (inherit set-mode) - ;; get-tab-choices : (listof (cons string thunk)) - ;; Override to add or remove panels - (define/public (get-tab-choices) - (list (cons "Term" 'term) - (cons "Syntax Object" 'stxobj))) + ;; get-tab-choices : (listof (cons string thunk)) + ;; Override to add or remove panels + (define/public (get-tab-choices) + (list (cons "Term" 'term) + (cons "Syntax Object" 'stxobj))) - (super-new) - (define tab-choices (get-tab-choices)) - (define tab-panel - (new tab-panel% - (choices (map car tab-choices)) - (parent parent) - (callback - (lambda (tp e) - (set-mode (cdr (list-ref tab-choices (send tp get-selection)))))))) - (define ecanvas (new editor-canvas% (editor text) (parent tab-panel))))) + (super-new) + (define tab-choices (get-tab-choices)) + (define tab-panel + (new tab-panel% + (choices (map car tab-choices)) + (parent parent) + (callback + (lambda (tp e) + (set-mode (cdr (list-ref tab-choices (send tp get-selection)))))))) + (define ecanvas (new editor-canvas% (editor text) (parent tab-panel))))) - ;; properties-displayer% - (define properties-displayer% - (class* object% () - (init-field text) +;; properties-displayer% +(define properties-displayer% + (class* object% () + (init-field text) - ;; display-null-info : -> void - (define/public (display-null-info) - (display "No syntax selected\n" n/a-sd)) + ;; display-null-info : -> void + (define/public (display-null-info) + (display "No syntax selected\n" n/a-sd)) - ;; display-meaning-info : syntax -> void - (define/public (display-meaning-info stx) - (when (and (identifier? stx) - (uninterned? (syntax-e stx))) - (display "Uninterned symbol!\n\n" key-sd)) - (display-binding-info stx) - (display-indirect-binding-info stx)) + ;; display-meaning-info : syntax -> void + (define/public (display-meaning-info stx) + (when (and (identifier? stx) + (uninterned? (syntax-e stx))) + (display "Uninterned symbol!\n\n" key-sd)) + (display-binding-info stx) + (display-indirect-binding-info stx)) - ;; display-binding-info : syntax -> void - (define/private (display-binding-info stx) - (display "Apparent identifier binding\n" key-sd) - (display-bindings stx)) + ;; display-binding-info : syntax -> void + (define/private (display-binding-info stx) + (display "Apparent identifier binding\n" key-sd) + (display-bindings stx)) - ;; display-indirect-binding-info : syntax -> void - (define/private (display-indirect-binding-info stx) - (cond - [(identifier? stx) - (display "Binding if used for #%top\n" key-sd) - (display-bindings (datum->syntax-object stx '#%top))] - [(and (syntax? stx) (pair? (syntax-e stx))) - (display "Binding if used for #%app\n" key-sd) - (display-bindings (datum->syntax-object stx '#%app))] - [else - (display "Binding if used for #%datum\n" key-sd) - (display-bindings (datum->syntax-object stx '#%datum))])) + ;; display-indirect-binding-info : syntax -> void + (define/private (display-indirect-binding-info stx) + (cond + [(identifier? stx) + (display "Binding if used for #%top\n" key-sd) + (display-bindings (datum->syntax stx '#%top))] + [(and (syntax? stx) (pair? (syntax-e stx))) + (display "Binding if used for #%app\n" key-sd) + (display-bindings (datum->syntax stx '#%app))] + [else + (display "Binding if used for #%datum\n" key-sd) + (display-bindings (datum->syntax stx '#%datum))])) - ;; display-bindings : syntax -> void - (define/private (display-bindings stx) - (unless (identifier? stx) - (display "Not applicable\n\n" n/a-sd)) - (when (identifier? stx) - (if (eq? (identifier-binding stx) 'lexical) - (display "lexical (all phases)\n" #f) - (for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx))) - binding-properties)) - (display "\n" #f))) + ;; display-bindings : syntax -> void + (define/private (display-bindings stx) + (unless (identifier? stx) + (display "Not applicable\n\n" n/a-sd)) + (when (identifier? stx) + (if (eq? (identifier-binding stx) 'lexical) + (display "lexical (all phases)\n" #f) + (for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx))) + binding-properties)) + (display "\n" #f))) - ;; display-binding-kvs : string bindinginfo -> void - (define/private (display-binding-kvs k v) - (display k sub-key-sd) - (display "\n" #f) - (cond [(eq? v #f) - (display " top-level or unbound\n" #f)] - [(list? v) - (display-subkv " defined in" (mpi->string (list-ref v 0))) - (display-subkv " as" (list-ref v 1)) - (display-subkv " imported from" (mpi->string (list-ref v 2))) - (display-subkv " as" (list-ref v 3)) - (if (list-ref v 4) - (display " via define-for-syntax" sub-key-sd))])) + ;; display-binding-kvs : string bindinginfo -> void + (define/private (display-binding-kvs k v) + (display k sub-key-sd) + (display "\n" #f) + (cond [(eq? v #f) + (display " top-level or unbound\n" #f)] + [(list? v) + (display-subkv " defined in" (mpi->string (list-ref v 0))) + (display-subkv " as" (list-ref v 1)) + (display-subkv " imported from" (mpi->string (list-ref v 2))) + (display-subkv " as" (list-ref v 3)) + (when (list-ref v 4) + (display " via define-for-syntax" sub-key-sd))])) - ;; display-stxobj-info : syntax -> void - (define/public (display-stxobj-info stx) - (display-source-info stx) - (display-extra-source-info stx) - (display-symbol-property-info stx)) + ;; display-stxobj-info : syntax -> void + (define/public (display-stxobj-info stx) + (display-source-info stx) + (display-extra-source-info stx) + (display-symbol-property-info stx)) - ;; display-source-info : syntax -> void - (define/private (display-source-info stx) - (define s-source (syntax-source stx)) - (define s-line (syntax-line stx)) - (define s-column (syntax-column stx)) - (define s-position (syntax-position stx)) - (define s-span0 (syntax-span stx)) - (define s-span (if (zero? s-span0) #f s-span0)) - (display "Source location\n" key-sd) - (if (or s-source s-line s-column s-position s-span) - (begin - (display-subkv "source" (prettify-source s-source)) - (display-subkv "line" s-line) - (display-subkv "column" s-column) - (display-subkv "position" s-position) - (display-subkv "span" s-span0)) - (display "No source location available\n" n/a-sd)) - (display "\n" #f)) + ;; display-source-info : syntax -> void + (define/private (display-source-info stx) + (define s-source (syntax-source stx)) + (define s-line (syntax-line stx)) + (define s-column (syntax-column stx)) + (define s-position (syntax-position stx)) + (define s-span0 (syntax-span stx)) + (define s-span (if (zero? s-span0) #f s-span0)) + (display "Source location\n" key-sd) + (if (or s-source s-line s-column s-position s-span) + (begin + (display-subkv "source" (prettify-source s-source)) + (display-subkv "line" s-line) + (display-subkv "column" s-column) + (display-subkv "position" s-position) + (display-subkv "span" s-span0)) + (display "No source location available\n" n/a-sd)) + (display "\n" #f)) - ;; display-extra-source-info : syntax -> void - (define/private (display-extra-source-info stx) - (display "Built-in properties\n" key-sd) - (display-subkv "source module" - (let ([mod (syntax-source-module stx)]) - (and mod (mpi->string mod)))) - (display-subkv "original?" (syntax-original? stx)) - (display "\n" #f)) + ;; display-extra-source-info : syntax -> void + (define/private (display-extra-source-info stx) + (display "Built-in properties\n" key-sd) + (display-subkv "source module" + (let ([mod (syntax-source-module stx)]) + (and mod (mpi->string mod)))) + (display-subkv "original?" (syntax-original? stx)) + (display "\n" #f)) - ;; display-symbol-property-info : syntax -> void - (define/private (display-symbol-property-info stx) - (let ([keys (syntax-property-symbol-keys stx)]) - (display "Additional properties\n" key-sd) - (when (null? keys) - (display "No additional properties available.\n" n/a-sd)) - (when (pair? keys) - (for-each (lambda (k) (display-subkv/value k (syntax-property stx k))) - keys)))) + ;; display-symbol-property-info : syntax -> void + (define/private (display-symbol-property-info stx) + (let ([keys (syntax-property-symbol-keys stx)]) + (display "Additional properties\n" key-sd) + (when (null? keys) + (display "No additional properties available.\n" n/a-sd)) + (when (pair? keys) + (for-each (lambda (k) (display-subkv/value k (syntax-property stx k))) + keys)))) - ;; display-kv : any any -> void - (define/private (display-kv key value) - (display (format "~a~n" key) key-sd) - (display (format "~s~n~n" value) #f)) + ;; display-kv : any any -> void + (define/private (display-kv key value) + (display (format "~a~n" key) key-sd) + (display (format "~s~n~n" value) #f)) - ;; display-subkv : any any -> void - (define/public (display-subkv k v) - (display (format "~a: " k) sub-key-sd) - (display (format "~a~n" v) #f)) + ;; display-subkv : any any -> void + (define/public (display-subkv k v) + (display (format "~a: " k) sub-key-sd) + (display (format "~a~n" v) #f)) - (define/public (display-subkv/value k v) - (display-subkv k v) - #; - (begin - (display (format "~a:~n" k) sub-key-sd) - (let* ([value-text (new text:standard-style-list% (auto-wrap #t))] - [value-snip (new editor-snip% (editor value-text))] - [value-port (make-text-port value-text)]) - (set-interactive-write-handler value-port) - (set-interactive-print-handler value-port) - (set-interactive-display-handler value-port) - (write v value-port) - (send value-text lock #t) - (send text insert value-snip) - (send text insert "\n") - #;(send ecanvas add-wide-snip value-snip)))) + (define/public (display-subkv/value k v) + (display-subkv k v) + #; + (begin + (display (format "~a:~n" k) sub-key-sd) + (let* ([value-text (new text:standard-style-list% (auto-wrap #t))] + [value-snip (new editor-snip% (editor value-text))] + [value-port (make-text-port value-text)]) + (set-interactive-write-handler value-port) + (set-interactive-print-handler value-port) + (set-interactive-display-handler value-port) + (write v value-port) + (send value-text lock #t) + (send text insert value-snip) + (send text insert "\n") + #;(send ecanvas add-wide-snip value-snip)))) - ;; display : string style-delta -> void - (define/private (display item sd) - (let ([p0 (send text last-position)]) - (send text insert item) - (let ([p1 (send text last-position)]) - (send text change-style sd p0 p1)))) + ;; display : string style-delta -> void + (define/private (display item sd) + (let ([p0 (send text last-position)]) + (send text insert item) + (let ([p1 (send text last-position)]) + (send text change-style sd p0 p1)))) - (super-new))) + (super-new))) - ;; lift/id : (identifier -> void) 'a -> void - (define (lift/id f) - (lambda (stx) (when (identifier? stx) (f stx)))) +;; lift/id : (identifier -> void) 'a -> void +(define (lift/id f) + (lambda (stx) (when (identifier? stx) (f stx)))) - ;; binding-properties : (listof (cons string (syntax -> any))) - (define binding-properties - (list (cons "in the standard phase" - (lift/id identifier-binding)) - (cons "in the transformer phase (\"for-syntax\")" - (lift/id identifier-transformer-binding)) - (cons "in the template phase (\"for-template\")" - (lift/id identifier-template-binding)))) +;; binding-properties : (listof (cons string (syntax -> any))) +(define binding-properties + (list (cons "in the standard phase" + (lift/id identifier-binding)) + (cons "in the transformer phase (\"for-syntax\")" + (lift/id identifier-transformer-binding)) + (cons "in the template phase (\"for-template\")" + (lift/id identifier-template-binding)))) - (define (uninterned? s) - (not (eq? s (string->symbol (symbol->string s))))) +(define (uninterned? s) + (not (eq? s (string->symbol (symbol->string s))))) - (define (prettify-source s) - (cond [(is-a? s editor<%>) - 'editor] - [else s])) +(define (prettify-source s) + (cond [(is-a? s editor<%>) + 'editor] + [else s])) + +;; Styles - ;; Styles - - (define key-sd - (let ([sd (new style-delta%)]) - (send sd set-delta-foreground "blue") - (send sd set-weight-on 'bold) - sd)) +(define key-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "blue") + (send sd set-weight-on 'bold) + sd)) - (define sub-key-sd - (let ([sd (new style-delta%)]) - (send sd set-delta-foreground "blue") - sd)) - - (define n/a-sd - (let ([sd (new style-delta%)]) - (send sd set-delta-foreground "gray") - sd)) +(define sub-key-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "blue") + sd)) - (define style:normal (make-object style-delta% 'change-normal)) +(define n/a-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "gray") + sd)) - (define style:hyper - (let ([s (make-object style-delta% 'change-normal)]) - (send s set-delta 'change-toggle-underline) - (send s set-delta-foreground "blue") - s)) - ) +(define style:normal (make-object style-delta% 'change-normal)) + +(define style:hyper + (let ([s (make-object style-delta% 'change-normal)]) + (send s set-delta 'change-toggle-underline) + (send s set-delta-foreground "blue") + s)) diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss index 609f25e..b6f30f1 100644 --- a/collects/macro-debugger/syntax-browser/text.ss +++ b/collects/macro-debugger/syntax-browser/text.ss @@ -1,324 +1,323 @@ -(module text mzscheme - (require (lib "list.ss") - (lib "class.ss") - (lib "mred.ss" "mred") - (lib "arrow.ss" "drscheme") - (lib "framework.ss" "framework") - "../util/notify.ss") +#lang scheme/base +(require scheme/list + scheme/class + scheme/gui + drscheme/arrow + framework/framework + "../util/notify.ss") - (provide text:hover<%> - text:hover-identifier<%> - text:mouse-drawings<%> - text:arrows<%> +(provide text:hover<%> + text:hover-identifier<%> + text:mouse-drawings<%> + text:arrows<%> - text:hover-mixin - text:hover-identifier-mixin - text:mouse-drawings-mixin - text:tacking-mixin - text:arrows-mixin) + text:hover-mixin + text:hover-identifier-mixin + text:mouse-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 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 billboard-brush + (send the-brush-list find-or-create-brush "white" 'solid)) - (define white (send the-color-database find-color "white")) +(define white (send the-color-database find-color "white")) - ;; A Drawing is (make-drawing number number (??? -> void) boolean boolean) - (define-struct drawing (start end draw visible? tacked?) #f) +;; A Drawing is (make-drawing number number (??? -> void) boolean boolean) +(define-struct drawing (start end draw visible? tacked?) #:mutable) - (define-struct idloc (start end id) #f) +(define-struct idloc (start end id)) - (define (mean x y) - (/ (+ x y) 2)) +(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-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 (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-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 (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<%> + (interface (text:basic<%>) + update-hover-position)) - (define text:hover-identifier<%> - (interface () - get-hovered-identifier - set-hovered-identifier - listen-hovered-identifier)) +(define text:hover-identifier<%> + (interface () + get-hovered-identifier + set-hovered-identifier + listen-hovered-identifier)) - (define text:mouse-drawings<%> - (interface (text:basic<%>) - add-mouse-drawing - for-each-drawing - delete-all-drawings)) +(define text:mouse-drawings<%> + (interface (text:basic<%>) + add-mouse-drawing + for-each-drawing + delete-all-drawings)) - (define text:arrows<%> - (interface (text:mouse-drawings<%>) - add-arrow - add-question-arrow - add-billboard)) +(define text:arrows<%> + (interface (text:mouse-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 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/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)) + (define/public (update-hover-position pos) + (void)) - (super-new))) + (super-new))) - (define text:hover-identifier-mixin - (mixin (text:hover<%>) (text:hover-identifier<%>) - (field/notify hovered-identifier (new notify-box% (value #f))) +(define text:hover-identifier-mixin + (mixin (text:hover<%>) (text:hover-identifier<%>) + (field/notify hovered-identifier (new notify-box% (value #f))) - (define idlocs null) + (define idlocs null) - (define/public (add-identifier-location start end id) - (set! idlocs (cons (make-idloc start end id) idlocs))) + (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/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))) + (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))) - (define text:mouse-drawings-mixin - (mixin (text:hover<%>) (text:mouse-drawings<%>) - (inherit dc-location-to-editor-location - find-position - invalidate-bitmap-cache) +(define text:mouse-drawings-mixin + (mixin (text:hover<%>) (text:mouse-drawings<%>) + (inherit dc-location-to-editor-location + find-position + invalidate-bitmap-cache) - ;; list of Drawings - (field [drawings-list null]) + ;; list of Drawings + (field [drawings-list null]) - (define/public add-mouse-drawing - (case-lambda - [(start end draw) - (add-mouse-drawing start end draw (box #f))] - [(start end draw tack-box) - (set! drawings-list - (cons (make-drawing start end draw #f tack-box) - drawings-list))])) + (define/public add-mouse-drawing + (case-lambda + [(start end draw) + (add-mouse-drawing start end draw (box #f))] + [(start end draw tack-box) + (set! drawings-list + (cons (make-drawing start end draw #f tack-box) + drawings-list))])) - (define/public (delete-all-drawings) - (set! drawings-list null)) + (define/public (delete-all-drawings) + (set! drawings-list null)) - (define/public-final (for-each-drawing f) - (for-each f drawings-list)) + (define/public-final (for-each-drawing f) + (for-each f drawings-list)) - (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-each-drawing - (lambda (d) - (when (or (drawing-visible? d) (unbox (drawing-tacked? d))) - ((drawing-draw d) this dc left top right bottom dx dy)))))) - - (define/override (update-hover-position pos) - (super update-hover-position pos) - (let ([changed? (update-visible-drawings pos)]) - (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))) - - (define/private (update-visible-drawings pos) - (let ([changed? #f]) - (for-each-drawing - (lambda (d) - (let ([vis? (<= (drawing-start d) pos (drawing-end d))]) - (unless (eqv? vis? (drawing-visible? d)) - (set-drawing-visible?! d vis?) - (set! changed? #t))))) - changed?)) - - (super-new))) - - (define text:tacking-mixin - (mixin (text:basic<%> text:mouse-drawings<%>) () - (inherit get-canvas - for-each-drawing) - (inherit-field drawings-list) - (super-new) - - (define/override (on-event ev) - (case (send ev get-event-type) - ((right-down) - (if (ormap (lambda (d) (drawing-visible? d)) drawings-list) - (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/private (make-tack/untack-menu) - (define menu (new popup-menu%)) - (new menu-item% (label "Tack") - (parent menu) - (callback - (lambda _ (tack)))) - (new menu-item% (label "Untack") - (parent menu) - (callback - (lambda _ (untack)))) - menu) - - (define/private (tack) + (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-each-drawing (lambda (d) - (when (drawing-visible? d) - (set-box! (drawing-tacked? d) #t))))) - (define/private (untack) + (when (or (drawing-visible? d) (unbox (drawing-tacked? d))) + ((drawing-draw d) this dc left top right bottom dx dy)))))) + + (define/override (update-hover-position pos) + (super update-hover-position pos) + (let ([changed? (update-visible-drawings pos)]) + (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))) + + (define/private (update-visible-drawings pos) + (let ([changed? #f]) (for-each-drawing (lambda (d) - (when (drawing-visible? d) - (set-box! (drawing-tacked? d) #f))))))) + (let ([vis? (<= (drawing-start d) pos (drawing-end d))]) + (unless (eqv? vis? (drawing-visible? d)) + (set-drawing-visible?! d vis?) + (set! changed? #t))))) + changed?)) - (define text:arrows-mixin - (mixin (text:mouse-drawings<%>) (text:arrows<%>) - (inherit position-location - add-mouse-drawing - find-wordbreak) + (super-new))) - (define/public (add-arrow from1 from2 to1 to2 color) - (internal-add-arrow from1 from2 to1 to2 color #f)) +(define text:tacking-mixin + (mixin (text:basic<%> text:mouse-drawings<%>) () + (inherit get-canvas + for-each-drawing) + (inherit-field drawings-list) + (super-new) - (define/public (add-question-arrow from1 from2 to1 to2 color) - (internal-add-arrow from1 from2 to1 to2 color #t)) + (define/override (on-event ev) + (case (send ev get-event-type) + ((right-down) + (if (ormap (lambda (d) (drawing-visible? d)) drawings-list) + (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/public (add-billboard pos1 pos2 str color-name) - (define color (send the-color-database find-color color-name)) + (define/private (make-tack/untack-menu) + (define menu (new popup-menu%)) + (new menu-item% (label "Tack") + (parent menu) + (callback + (lambda _ (tack)))) + (new menu-item% (label "Untack") + (parent menu) + (callback + (lambda _ (untack)))) + menu) + + (define/private (tack) + (for-each-drawing + (lambda (d) + (when (drawing-visible? d) + (set-box! (drawing-tacked? d) #t))))) + (define/private (untack) + (for-each-drawing + (lambda (d) + (when (drawing-visible? d) + (set-box! (drawing-tacked? d) #f))))))) + +(define text:arrows-mixin + (mixin (text:mouse-drawings<%>) (text:arrows<%>) + (inherit position-location + add-mouse-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-mouse-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 ([(x y) (range->mean-loc pos1 pos1)] - [(fw fh _d _v) (send dc get-text-extent "y")]) + (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) - (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-mouse-drawing pos1 pos2 draw))) + (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-mouse-drawing from1 from2 draw tack-box) + (add-mouse-drawing to1 to2 draw tack-box)))) - (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-mouse-drawing from1 from2 draw tack-box) - (add-mouse-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 (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 (?-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 (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))) - (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))) - (super-new))) +(define text:mouse-drawings% + (text:mouse-drawings-mixin + (text:hover-mixin + text:standard-style-list%))) - (define text:mouse-drawings% - (text:mouse-drawings-mixin - (text:hover-mixin - text:standard-style-list%))) - - (define text:arrows% - (text:arrows-mixin - (text:tacking-mixin - text:mouse-drawings%))) - ) +(define text:arrows% + (text:arrows-mixin + (text:tacking-mixin + text:mouse-drawings%))) diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.ss index bc7a71d..7e5e1af 100644 --- a/collects/macro-debugger/syntax-browser/util.ss +++ b/collects/macro-debugger/syntax-browser/util.ss @@ -1,60 +1,59 @@ -(module util mzscheme - (require (lib "class.ss")) - (provide with-unlock - make-text-port - mpi->string - mpi->list) +#lang scheme/base +(require scheme/class) +(provide with-unlock + make-text-port + mpi->string + mpi->list) - ;; with-unlock SYNTAX (expression) - ;; (with-unlock text-expression . body) - (define-syntax with-unlock - (syntax-rules () - [(with-unlock text . body) - (let* ([t text] - [locked? (send t is-locked?)]) - (send t lock #f) - (begin0 (let () . body) - (send t lock locked?)))])) +;; with-unlock SYNTAX (expression) +;; (with-unlock text-expression . body) +(define-syntax with-unlock + (syntax-rules () + [(with-unlock text . body) + (let* ([t text] + [locked? (send t is-locked?)]) + (send t lock #f) + (begin0 (let () . body) + (send t lock locked?)))])) - ;; make-text-port : text (-> number) -> port - ;; builds a port from a text object. - (define (make-text-port text end-position) - (make-output-port #f - always-evt - (lambda (s start end flush? enable-break?) - (send text insert - (bytes->string/utf-8 s #f start end) - (end-position)) - (- end start)) - void - (lambda (special buffer? enable-break?) - (send text insert special (end-position)) - #t))) +;; make-text-port : text (-> number) -> port +;; builds a port from a text object. +(define (make-text-port text end-position) + (make-output-port #f + always-evt + (lambda (s start end flush? enable-break?) + (send text insert + (bytes->string/utf-8 s #f start end) + (end-position)) + (- end start)) + void + (lambda (special buffer? enable-break?) + (send text insert special (end-position)) + #t))) - ;; mpi->string : module-path-index -> string - (define (mpi->string mpi) - (if (module-path-index? mpi) - (let ([mps (mpi->list mpi)]) - (cond [(and (pair? mps) (pair? (cdr mps))) - (apply string-append - (format "~s" (car mps)) - (map (lambda (x) (format " <= ~s" x)) (cdr mps)))] - [(and (pair? mps) (null? (cdr mps))) - (format "~s" (car mps))] - [(null? mps) "this module"])) - (format "~s" mpi))) +;; mpi->string : module-path-index -> string +(define (mpi->string mpi) + (if (module-path-index? mpi) + (let ([mps (mpi->list mpi)]) + (cond [(and (pair? mps) (pair? (cdr mps))) + (apply string-append + (format "~s" (car mps)) + (map (lambda (x) (format " <= ~s" x)) (cdr mps)))] + [(and (pair? mps) (null? (cdr mps))) + (format "~s" (car mps))] + [(null? mps) "this module"])) + (format "~s" mpi))) - ;; mpi->list : module-path-index -> (list-of module-spec) - (define (mpi->list mpi) - (cond [(module-path-index? mpi) - (let-values ([(path rel) (module-path-index-split mpi)]) - (cond [(and (pair? path) (memq (car path) '(file lib planet))) - (cons path null)] - [path - (cons path (mpi->list rel))] - [else '()]))] - [(not mpi) - '()] - [else (list mpi)])) - ) +;; mpi->list : module-path-index -> (list-of module-spec) +(define (mpi->list mpi) + (cond [(module-path-index? mpi) + (let-values ([(path rel) (module-path-index-split mpi)]) + (cond [(and (pair? path) (memq (car path) '(file lib planet))) + (cons path null)] + [path + (cons path (mpi->list rel))] + [else '()]))] + [(not mpi) + '()] + [else (list mpi)])) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 6442606..9907065 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -1,258 +1,257 @@ -(module widget mzscheme - (require (lib "class.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - (lib "list.ss") - (lib "plt-match.ss") - (lib "kw.ss") - (lib "boundmap.ss" "syntax") - "interfaces.ss" - "params.ss" - "controller.ss" - "display.ss" - "keymap.ss" - "hrule-snip.ss" - "properties.ss" - "text.ss" - "util.ss") - (provide widget% - widget-keymap% - widget-context-menu%) +#lang mzscheme +(require scheme/class + mred/mred + framework/framework + scheme/list + scheme/match + mzlib/kw + syntax/boundmap + "interfaces.ss" + "params.ss" + "controller.ss" + "display.ss" + "keymap.ss" + "hrule-snip.ss" + "properties.ss" + "text.ss" + "util.ss") +(provide widget% + widget-keymap% + widget-context-menu%) - ;; widget% - ;; A syntax widget creates its own syntax-controller. - (define widget% - (class* object% (widget-hooks<%>) - (init parent) - (init-field config) +;; widget% +;; A syntax widget creates its own syntax-controller. +(define widget% + (class* object% (widget-hooks<%>) + (init parent) + (init-field config) - (define controller (new controller%)) + (define controller (new controller%)) - (define -main-panel - (new vertical-panel% (parent parent))) - (define -split-panel - (new panel:horizontal-dragable% (parent -main-panel))) - (define -text (new browser-text%)) - (define -ecanvas - (new editor-canvas% (parent -split-panel) (editor -text))) - (define -props-panel (new horizontal-panel% (parent -split-panel))) - (define props - (new properties-view% - (parent -props-panel) - (controller controller))) - (define props-percentage (send config pref:props-percentage)) + (define -main-panel + (new vertical-panel% (parent parent))) + (define -split-panel + (new panel:horizontal-dragable% (parent -main-panel))) + (define -text (new browser-text%)) + (define -ecanvas + (new editor-canvas% (parent -split-panel) (editor -text))) + (define -props-panel (new horizontal-panel% (parent -split-panel))) + (define props + (new properties-view% + (parent -props-panel) + (controller controller))) + (define props-percentage (send config pref:props-percentage)) - (define/public (setup-keymap) - (new widget-keymap% - (editor -text) - (widget this))) + (define/public (setup-keymap) + (new widget-keymap% + (editor -text) + (widget this))) - (send -text set-styles-sticky #f) - (send -text lock #t) + (send -text set-styles-sticky #f) + (send -text lock #t) - (send -split-panel set-percentages - (list (- 1 props-percentage) props-percentage)) + (send -split-panel set-percentages + (list (- 1 props-percentage) props-percentage)) - ;; syntax-properties-controller<%> methods + ;; syntax-properties-controller<%> methods - (define/public (props-shown?) - (send -props-panel is-shown?)) + (define/public (props-shown?) + (send -props-panel is-shown?)) - (define/public (toggle-props) - (show-props (not (send -props-panel is-shown?)))) + (define/public (toggle-props) + (show-props (not (send -props-panel is-shown?)))) - (define/public (show-props show?) - (if show? - (unless (send -props-panel is-shown?) - (send -split-panel add-child -props-panel) - (send -split-panel set-percentages - (list (- 1 props-percentage) props-percentage)) - (send -props-panel show #t)) - (when (send -props-panel is-shown?) - (set! props-percentage - (cadr (send -split-panel get-percentages))) - (send -split-panel delete-child -props-panel) - (send -props-panel show #f)))) + (define/public (show-props show?) + (if show? + (unless (send -props-panel is-shown?) + (send -split-panel add-child -props-panel) + (send -split-panel set-percentages + (list (- 1 props-percentage) props-percentage)) + (send -props-panel show #t)) + (when (send -props-panel is-shown?) + (set! props-percentage + (cadr (send -split-panel get-percentages))) + (send -split-panel delete-child -props-panel) + (send -props-panel show #f)))) - ;; + ;; - (define/public (get-controller) controller) + (define/public (get-controller) controller) - ;; + ;; - (define/public (get-main-panel) -main-panel) + (define/public (get-main-panel) -main-panel) - (define/public (shutdown) - (unless (= props-percentage (send config pref:props-percentage)) - (send config pref:props-percentage props-percentage))) + (define/public (shutdown) + (unless (= props-percentage (send config pref:props-percentage)) + (send config pref:props-percentage props-percentage))) - ;; syntax-browser<%> Methods + ;; syntax-browser<%> Methods - (define/public (add-text text) - (with-unlock -text - (send -text insert text))) + (define/public (add-text text) + (with-unlock -text + (send -text insert text))) - (define/public (add-error-text text) - (with-unlock -text - (let ([a (send -text last-position)]) - (send -text insert text) - (let ([b (send -text last-position)]) - (send -text change-style error-text-style a b))))) - - (define/public (add-clickback text handler) - (with-unlock -text - (let ([a (send -text last-position)]) - (send -text insert text) - (let ([b (send -text last-position)]) - (send -text set-clickback a b handler) - (send -text change-style clickback-style a b))))) + (define/public (add-error-text text) + (with-unlock -text + (let ([a (send -text last-position)]) + (send -text insert text) + (let ([b (send -text last-position)]) + (send -text change-style error-text-style a b))))) + + (define/public (add-clickback text handler) + (with-unlock -text + (let ([a (send -text last-position)]) + (send -text insert text) + (let ([b (send -text last-position)]) + (send -text set-clickback a b handler) + (send -text change-style clickback-style a b))))) - (define/public add-syntax - (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null] - hi2-color [hi2-stxs null]) - (define (get-binder id) - (module-identifier-mapping-get alpha-table id (lambda () #f))) - (when (and (pair? hi-stxs) (not hi-color)) - (error 'syntax-widget%::add-syntax "no highlight color specified")) - (let ([display (internal-add-syntax stx)] - [definite-table (make-hash-table)]) - (when (and hi2-color (pair? hi2-stxs)) - (send display highlight-syntaxes hi2-stxs hi2-color)) - (when (and hi-color (pair? hi-stxs)) - (send display highlight-syntaxes hi-stxs hi-color)) - (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites) - (when alpha-table - (let ([range (send display get-range)] - [start (send display get-start-position)]) - (define (adjust n) (+ start n)) - (for-each - (lambda (id) - #; ;; DISABLED - (match (identifier-binding id) - [(list src-mod src-name nom-mod nom-name _) - (for-each (lambda (id-r) - (send -text add-billboard - (adjust (car id-r)) - (adjust (cdr id-r)) - (string-append "from " - (mpi->string src-mod)) - (if (hash-table-get definite-table id #f) - "blue" - "purple"))) - (send range get-ranges id))] - [_ (void)]) - - (let ([binder (get-binder id)]) - (when binder - (for-each - (lambda (binder-r) - (for-each (lambda (id-r) + (define/public add-syntax + (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null] + hi2-color [hi2-stxs null]) + (define (get-binder id) + (module-identifier-mapping-get alpha-table id (lambda () #f))) + (when (and (pair? hi-stxs) (not hi-color)) + (error 'syntax-widget%::add-syntax "no highlight color specified")) + (let ([display (internal-add-syntax stx)] + [definite-table (make-hash-table)]) + (when (and hi2-color (pair? hi2-stxs)) + (send display highlight-syntaxes hi2-stxs hi2-color)) + (when (and hi-color (pair? hi-stxs)) + (send display highlight-syntaxes hi-stxs hi-color)) + (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites) + (when alpha-table + (let ([range (send display get-range)] + [start (send display get-start-position)]) + (define (adjust n) (+ start n)) + (for-each + (lambda (id) + #; ;; DISABLED + (match (identifier-binding id) + [(list src-mod src-name nom-mod nom-name _) + (for-each (lambda (id-r) + (send -text add-billboard + (adjust (car id-r)) + (adjust (cdr id-r)) + (string-append "from " + (mpi->string src-mod)) (if (hash-table-get definite-table id #f) - (send -text add-arrow - (adjust (car binder-r)) - (adjust (cdr binder-r)) - (adjust (car id-r)) - (adjust (cdr id-r)) - "blue") - (send -text add-question-arrow - (adjust (car binder-r)) - (adjust (cdr binder-r)) - (adjust (car id-r)) - (adjust (cdr id-r)) - "purple"))) - (send range get-ranges id))) - (send range get-ranges binder))))) - (send range get-identifier-list)))) - display))) + "blue" + "purple"))) + (send range get-ranges id))] + [_ (void)]) - (define/public (add-separator) - (with-unlock -text - (send* -text - (insert (new hrule-snip%)) - (insert "\n")))) + (let ([binder (get-binder id)]) + (when binder + (for-each + (lambda (binder-r) + (for-each (lambda (id-r) + (if (hash-table-get definite-table id #f) + (send -text add-arrow + (adjust (car binder-r)) + (adjust (cdr binder-r)) + (adjust (car id-r)) + (adjust (cdr id-r)) + "blue") + (send -text add-question-arrow + (adjust (car binder-r)) + (adjust (cdr binder-r)) + (adjust (car id-r)) + (adjust (cdr id-r)) + "purple"))) + (send range get-ranges id))) + (send range get-ranges binder))))) + (send range get-identifier-list)))) + display))) - (define/public (erase-all) - (with-unlock -text - (send -text erase) - (send -text delete-all-drawings)) - (send controller remove-all-syntax-displays)) + (define/public (add-separator) + (with-unlock -text + (send* -text + (insert (new hrule-snip%)) + (insert "\n")))) - (define/public (get-text) -text) + (define/public (erase-all) + (with-unlock -text + (send -text erase) + (send -text delete-all-drawings)) + (send controller remove-all-syntax-displays)) - ;; internal-add-syntax : syntax -> display - (define/private (internal-add-syntax stx) - (with-unlock -text - (parameterize ((current-default-columns (calculate-columns))) - (let ([display (print-syntax-to-editor stx -text controller)]) - (send* -text - (insert "\n") - ;(scroll-to-position current-position) - ) - display)))) + (define/public (get-text) -text) - (define/private (calculate-columns) - (define style (code-style -text)) - (define char-width (send style get-text-width (send -ecanvas get-dc))) - (define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) - (sub1 (inexact->exact (floor (/ canvas-w char-width))))) + ;; internal-add-syntax : syntax -> display + (define/private (internal-add-syntax stx) + (with-unlock -text + (parameterize ((current-default-columns (calculate-columns))) + (let ([display (print-syntax-to-editor stx -text controller)]) + (send* -text + (insert "\n") + ;(scroll-to-position current-position) + ) + display)))) - ;; Initialize - (super-new) - (setup-keymap))) + (define/private (calculate-columns) + (define style (code-style -text)) + (define char-width (send style get-text-width (send -ecanvas get-dc))) + (define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) + (sub1 (inexact->exact (floor (/ canvas-w char-width))))) - (define clickback-style - (let ([sd (new style-delta%)]) - (send sd set-delta 'change-toggle-underline) - (send sd set-delta-foreground "blue") - sd)) + ;; Initialize + (super-new) + (setup-keymap))) - (define error-text-style - (let ([sd (new style-delta%)]) - (send sd set-delta 'change-italic) - (send sd set-delta-foreground "red") - sd)) +(define clickback-style + (let ([sd (new style-delta%)]) + (send sd set-delta 'change-toggle-underline) + (send sd set-delta-foreground "blue") + sd)) - ;; Specialized classes for widget +(define error-text-style + (let ([sd (new style-delta%)]) + (send sd set-delta 'change-italic) + (send sd set-delta-foreground "red") + sd)) - (define widget-keymap% - (class syntax-keymap% - (init-field widget) - (super-new (controller (send widget get-controller))) - (inherit add-function) - (inherit-field controller) +;; Specialized classes for widget - (define/override (get-context-menu%) - widget-context-menu%) +(define widget-keymap% + (class syntax-keymap% + (init-field widget) + (super-new (controller (send widget get-controller))) + (inherit add-function) + (inherit-field controller) - (add-function "show-syntax-properties" - (lambda (i e) - (send widget toggle-props))) + (define/override (get-context-menu%) + widget-context-menu%) - (define/public (get-widget) widget))) + (add-function "show-syntax-properties" + (lambda (i e) + (send widget toggle-props))) - (define widget-context-menu% - (class context-menu% - (inherit-field keymap) - (inherit-field props-menu) + (define/public (get-widget) widget))) - (define/override (on-demand) - (send props-menu set-label - (if (send (send keymap get-widget) props-shown?) - "Hide syntax properties" - "Show syntax properties")) - (super on-demand)) - (super-new))) +(define widget-context-menu% + (class context-menu% + (inherit-field keymap) + (inherit-field props-menu) - (define browser-text% - (class (text:arrows-mixin - (text:tacking-mixin - (text:mouse-drawings-mixin - (text:hover-mixin - (text:hide-caret/selection-mixin - (editor:standard-style-list-mixin text:basic%)))))) - (inherit set-autowrap-bitmap) - (define/override (default-style-name) "Basic") - (super-new (auto-wrap #t)) - (set-autowrap-bitmap #f))) - ) + (define/override (on-demand) + (send props-menu set-label + (if (send (send keymap get-widget) props-shown?) + "Hide syntax properties" + "Show syntax properties")) + (super on-demand)) + (super-new))) + +(define browser-text% + (class (text:arrows-mixin + (text:tacking-mixin + (text:mouse-drawings-mixin + (text:hover-mixin + (text:hide-caret/selection-mixin + (editor:standard-style-list-mixin text:basic%)))))) + (inherit set-autowrap-bitmap) + (define/override (default-style-name) "Basic") + (super-new (auto-wrap #t)) + (set-autowrap-bitmap #f))) diff --git a/collects/macro-debugger/view/cursor.ss b/collects/macro-debugger/view/cursor.ss index 0464795..c6bcce1 100644 --- a/collects/macro-debugger/view/cursor.ss +++ b/collects/macro-debugger/view/cursor.ss @@ -1,132 +1,131 @@ -(module cursor mzscheme - (provide cursor? - cursor:new - cursor:add-to-end! - cursor:remove-current! +#lang scheme/base +(require scheme/promise) +(provide cursor? + cursor:new + cursor:add-to-end! + cursor:remove-current! - cursor:next - cursor:prev + cursor:next + cursor:prev - cursor:at-start? - cursor:at-end? + cursor:at-start? + cursor:at-end? - cursor:has-next? - cursor:has-prev? + cursor:has-next? + cursor:has-prev? - cursor:move-next - cursor:move-prev - cursor:move-to-start - cursor:move-to-end - cursor:skip-to + cursor:move-next + cursor:move-prev + cursor:move-to-start + cursor:move-to-end + cursor:skip-to - cursor->list - cursor:prefix->list - cursor:suffix->list) + cursor->list + cursor:prefix->list + cursor:suffix->list) - (define-syntax stream-cons - (syntax-rules () - [(stream-cons x y) - (delay (cons x y))])) +(define-syntax stream-cons + (syntax-rules () + [(stream-cons x y) + (delay (cons x y))])) - (define (stream-car x) - (if (promise? x) - (car (force x)) - (car x))) +(define (stream-car x) + (if (promise? x) + (car (force x)) + (car x))) - (define (stream-cdr x) - (if (promise? x) - (cdr (force x)) - (cdr x))) - - (define (stream-null? x) - (or (null? x) - (and (promise? x) (null? (force x))))) +(define (stream-cdr x) + (if (promise? x) + (cdr (force x)) + (cdr x))) - (define (stream-append x y) - (if (stream-null? x) - y - (stream-cons (stream-car x) - (stream-append (stream-cdr x) y)))) +(define (stream-null? x) + (or (null? x) + (and (promise? x) (null? (force x))))) - (define (stream->list s) - (if (stream-null? s) - null - (cons (stream-car s) (stream->list (stream-cdr s))))) +(define (stream-append x y) + (if (stream-null? x) + y + (stream-cons (stream-car x) + (stream-append (stream-cdr x) y)))) - ;; Cursors - - ;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a)) - (define-struct cursor (prefix suffixp)) - - (define (cursor:new items) - (make-cursor null items)) +(define (stream->list s) + (if (stream-null? s) + null + (cons (stream-car s) (stream->list (stream-cdr s))))) - (define (cursor:add-to-end! c items) - (let ([suffix (cursor-suffixp c)]) - (set-cursor-suffixp! c (stream-append suffix items)))) +;; Cursors - (define (cursor:remove-current! c) - (when (cursor:has-next? c) - (set-cursor-suffixp! c (stream-cdr (cursor-suffixp c))))) +;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a)) +(define-struct cursor (prefix suffixp) #:mutable) - (define (cursor:next c) - (let ([suffix (cursor-suffixp c)]) - (if (stream-null? suffix) - #f - (stream-car suffix)))) +(define (cursor:new items) + (make-cursor null items)) - (define (cursor:prev c) - (let ([prefix (cursor-prefix c)]) - (if (pair? prefix) - (car prefix) - #f))) +(define (cursor:add-to-end! c items) + (let ([suffix (cursor-suffixp c)]) + (set-cursor-suffixp! c (stream-append suffix items)))) - (define (cursor:move-prev c) - (when (pair? (cursor-prefix c)) - (let ([old-prefix (cursor-prefix c)]) - (set-cursor-prefix! c (cdr old-prefix)) - (set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c)))))) +(define (cursor:remove-current! c) + (when (cursor:has-next? c) + (set-cursor-suffixp! c (stream-cdr (cursor-suffixp c))))) - (define (cursor:move-next c) - (when (cursor:has-next? c) - (let* ([old-suffixp (cursor-suffixp c)]) - (set-cursor-prefix! c (cons (stream-car old-suffixp) - (cursor-prefix c))) - (set-cursor-suffixp! c (stream-cdr old-suffixp))))) +(define (cursor:next c) + (let ([suffix (cursor-suffixp c)]) + (if (stream-null? suffix) + #f + (stream-car suffix)))) - (define (cursor:at-start? c) - (null? (cursor-prefix c))) - (define (cursor:at-end? c) - (stream-null? (cursor-suffixp c))) - (define (cursor:has-next? c) - (not (cursor:at-end? c))) - (define (cursor:has-prev? c) - (not (cursor:at-start? c))) - - (define (cursor:move-to-start c) - (when (cursor:has-prev? c) - (cursor:move-prev c) - (cursor:move-to-start c))) - - (define (cursor:move-to-end c) - (when (cursor:has-next? c) - (cursor:move-next c) - (cursor:move-to-end c))) +(define (cursor:prev c) + (let ([prefix (cursor-prefix c)]) + (if (pair? prefix) + (car prefix) + #f))) - (define (cursor:skip-to c i) - (unless (or (eq? (cursor:next c) i) (cursor:at-end? c)) - (cursor:move-next c) - (cursor:skip-to c i))) - - (define (cursor->list c) - (append (cursor:prefix->list c) - (cursor:suffix->list c))) +(define (cursor:move-prev c) + (when (pair? (cursor-prefix c)) + (let ([old-prefix (cursor-prefix c)]) + (set-cursor-prefix! c (cdr old-prefix)) + (set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c)))))) - (define (cursor:prefix->list c) - (reverse (cursor-prefix c))) +(define (cursor:move-next c) + (when (cursor:has-next? c) + (let* ([old-suffixp (cursor-suffixp c)]) + (set-cursor-prefix! c (cons (stream-car old-suffixp) + (cursor-prefix c))) + (set-cursor-suffixp! c (stream-cdr old-suffixp))))) - (define (cursor:suffix->list c) - (stream->list (cursor-suffixp c))) - - ) +(define (cursor:at-start? c) + (null? (cursor-prefix c))) +(define (cursor:at-end? c) + (stream-null? (cursor-suffixp c))) +(define (cursor:has-next? c) + (not (cursor:at-end? c))) +(define (cursor:has-prev? c) + (not (cursor:at-start? c))) + +(define (cursor:move-to-start c) + (when (cursor:has-prev? c) + (cursor:move-prev c) + (cursor:move-to-start c))) + +(define (cursor:move-to-end c) + (when (cursor:has-next? c) + (cursor:move-next c) + (cursor:move-to-end c))) + +(define (cursor:skip-to c i) + (unless (or (eq? (cursor:next c) i) (cursor:at-end? c)) + (cursor:move-next c) + (cursor:skip-to c i))) + +(define (cursor->list c) + (append (cursor:prefix->list c) + (cursor:suffix->list c))) + +(define (cursor:prefix->list c) + (reverse (cursor-prefix c))) + +(define (cursor:suffix->list c) + (stream->list (cursor-suffixp c))) diff --git a/collects/macro-debugger/view/debug-format.ss b/collects/macro-debugger/view/debug-format.ss index b2151f6..4bedfc5 100644 --- a/collects/macro-debugger/view/debug-format.ss +++ b/collects/macro-debugger/view/debug-format.ss @@ -1,55 +1,53 @@ -(module debug-format mzscheme - (require (lib "pretty.ss")) - (provide write-debug-file - load-debug-file) +#lang scheme/base +(require scheme/pretty) +(provide write-debug-file + load-debug-file) +(define (write-debug-file file exn events) + (with-output-to-file file + (lambda () + (write `(list ,@(map (lambda (e) (serialize-datum e)) events))) + (newline) + (write (exn-message exn)) + (newline) + (write (map serialize-context-frame + (continuation-mark-set->context + (exn-continuation-marks exn))))) + 'replace)) - (define (write-debug-file file exn events) - (with-output-to-file file +(define (serialize-datum d) + (cond [(number? d) `(quote ,d)] + [(boolean? d) `(quote ,d)] + [(symbol? d) `(quote ,d)] + [(string? d) `(quote ,d)] + [(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))] + [(null? d) '()] + [(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))] + [(syntax? d) `(datum->syntax #f ',(syntax->datum d))] + #;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))] + [else (error 'serialize-datum "got ~s" d)])) + +(define (serialize-context-frame frame) + (cons (car frame) + (if (cdr frame) + (serialize-srcloc (cdr frame)) + null))) + +(define (serialize-srcloc s) + (list (let ([src (srcloc-source s)]) + (cond [(path? src) (path->string src)] + [(string? src) src] + [else '?])) + (srcloc-line s) + (srcloc-column s))) + +(define (load-debug-file file) + (parameterize ((read-accept-compiled #t)) + (with-input-from-file file (lambda () - (write `(list ,@(map (lambda (e) (serialize-datum e)) events))) - (newline) - (write (exn-message exn)) - (newline) - (write (map serialize-context-frame - (continuation-mark-set->context - (exn-continuation-marks exn))))) - 'replace)) - - (define (serialize-datum d) - (cond [(number? d) `(quote ,d)] - [(boolean? d) `(quote ,d)] - [(symbol? d) `(quote ,d)] - [(string? d) `(quote ,d)] - [(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))] - [(null? d) '()] - [(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))] - [(syntax? d) `(datum->syntax-object #f ',(syntax-object->datum d))] - #;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))] - [else (error 'serialize-datum "got ~s" d)])) - - (define (serialize-context-frame frame) - (cons (car frame) - (if (cdr frame) - (serialize-srcloc (cdr frame)) - null))) - - (define (serialize-srcloc s) - (list (let ([src (srcloc-source s)]) - (cond [(path? src) (path->string src)] - [(string? src) src] - [else '?])) - (srcloc-line s) - (srcloc-column s))) - - (define (load-debug-file file) - (parameterize ((read-accept-compiled #t)) - (with-input-from-file file - (lambda () - (let* ([events-expr (read)] - [exnmsg (read)] - [ctx (read)]) - (let ([events (eval events-expr)]) - (values events exnmsg ctx))))))) - ) + (let* ([events-expr (read)] + [exnmsg (read)] + [ctx (read)]) + (let ([events (eval events-expr)]) + (values events exnmsg ctx))))))) diff --git a/collects/macro-debugger/view/debug.ss b/collects/macro-debugger/view/debug.ss index c3de7b7..3260372 100644 --- a/collects/macro-debugger/view/debug.ss +++ b/collects/macro-debugger/view/debug.ss @@ -1,35 +1,34 @@ -(module debug mzscheme - (require (lib "pretty.ss") - (lib "class.ss") - "debug-format.ss" - "prefs.ss" - "view.ss") - (provide debug-file) +#lang scheme/base +(require scheme/pretty + scheme/class + "debug-format.ss" + "prefs.ss" + "view.ss") +(provide debug-file) - (define (widget-mixin %) - (class % - (define/override (top-interaction-kw? x) - (eq? (syntax-e x) '#%top-interaction)) - (super-new))) +(define (widget-mixin %) + (class % + (define/override (top-interaction-kw? x) + (eq? (syntax-e x) '#%top-interaction)) + (super-new))) - (define stepper-frame% - (class macro-stepper-frame% - (define/override (get-macro-stepper-widget%) - (widget-mixin (super get-macro-stepper-widget%))) - (super-new))) +(define stepper-frame% + (class macro-stepper-frame% + (define/override (get-macro-stepper-widget%) + (widget-mixin (super get-macro-stepper-widget%))) + (super-new))) - (define (make-stepper) - (let ([f (new macro-stepper-frame% - (config (new macro-stepper-config/prefs%)))]) - (send f show #t) - (send f get-widget))) +(define (make-stepper) + (let ([f (new macro-stepper-frame% + (config (new macro-stepper-config/prefs%)))]) + (send f show #t) + (send f get-widget))) - (define (debug-file file) - (let-values ([(events msg ctx) (load-debug-file file)]) - (pretty-print msg) - (pretty-print ctx) - (let* ([w (make-stepper)]) - (send w add-trace events) - w))) - ) +(define (debug-file file) + (let-values ([(events msg ctx) (load-debug-file file)]) + (pretty-print msg) + (pretty-print ctx) + (let* ([w (make-stepper)]) + (send w add-trace events) + w))) diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.ss index 774893f..8a43414 100644 --- a/collects/macro-debugger/view/extensions.ss +++ b/collects/macro-debugger/view/extensions.ss @@ -1,112 +1,111 @@ -(module extensions mzscheme - (require (lib "class.ss") - (lib "unit.ss") - (lib "list.ss") - (lib "plt-match.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - (lib "boundmap.ss" "syntax") - "interfaces.ss" - "prefs.ss" - "warning.ss" - "hiding-panel.ss" - (prefix s: "../syntax-browser/widget.ss") - "../model/deriv.ss" - "../model/deriv-util.ss" - "../model/trace.ss" - "../model/hide.ss" - "../model/steps.ss" - "cursor.ss" - "util.ss") - (provide stepper-keymap% - stepper-context-menu% - stepper-syntax-widget%) +#lang scheme/base +(require scheme/class + scheme/unit + scheme/list + scheme/match + scheme/gui + framework/framework + syntax/boundmap + "interfaces.ss" + "prefs.ss" + "warning.ss" + "hiding-panel.ss" + (prefix-in s: "../syntax-browser/widget.ss") + "../model/deriv.ss" + "../model/deriv-util.ss" + "../model/trace.ss" + "../model/hide.ss" + "../model/steps.ss" + "cursor.ss" + "../util/notify.ss") +(provide stepper-keymap% + stepper-context-menu% + stepper-syntax-widget%) - ;; Extensions +;; Extensions - (define stepper-keymap% - (class s:widget-keymap% - (init-field macro-stepper) - (inherit-field controller) - (inherit add-function) +(define stepper-keymap% + (class s:widget-keymap% + (init-field macro-stepper) + (inherit-field controller) + (inherit add-function) - (super-new) + (super-new) - (define/override (get-context-menu%) - stepper-context-menu%) + (define/override (get-context-menu%) + stepper-context-menu%) - (define/public (get-hiding-panel) - (send macro-stepper get-macro-hiding-prefs)) + (define/public (get-hiding-panel) + (send macro-stepper get-macro-hiding-prefs)) - (add-function "hiding:show-macro" - (lambda (i e) - (send* (get-hiding-panel) - (add-show-identifier) - (refresh)))) - - (add-function "hiding:hide-macro" - (lambda (i e) - (send* (get-hiding-panel) - (add-hide-identifier) - (refresh)))))) + (add-function "hiding:show-macro" + (lambda (i e) + (send* (get-hiding-panel) + (add-show-identifier) + (refresh)))) + + (add-function "hiding:hide-macro" + (lambda (i e) + (send* (get-hiding-panel) + (add-hide-identifier) + (refresh)))))) - (define stepper-context-menu% - (class s:widget-context-menu% - (inherit-field keymap) - (inherit add-separator) - - (field [show-macro #f] - [hide-macro #f]) - - (define/override (after-selection-items) - (super after-selection-items) - (add-separator) - (set! show-macro - (new menu-item% (label "Show this macro") (parent this) - (callback (lambda (i e) - (send keymap call-function "hiding:show-macro" i e))))) - (set! hide-macro - (new menu-item% (label "Hide this macro") (parent this) - (callback (lambda (i e) - (send keymap call-function "hiding:hide-macro" i e))))) - (void)) - - (define/override (on-demand) - (define hiding-panel (send keymap get-hiding-panel)) - (define controller (send keymap get-controller)) - (define stx (send controller get-selected-syntax)) - (define id? (identifier? stx)) - (send show-macro enable id?) - (send hide-macro enable id?) - (super on-demand)) +(define stepper-context-menu% + (class s:widget-context-menu% + (inherit-field keymap) + (inherit add-separator) + + (field [show-macro #f] + [hide-macro #f]) + + (define/override (after-selection-items) + (super after-selection-items) + (add-separator) + (set! show-macro + (new menu-item% (label "Show this macro") (parent this) + (callback (lambda (i e) + (send keymap call-function "hiding:show-macro" i e))))) + (set! hide-macro + (new menu-item% (label "Hide this macro") (parent this) + (callback (lambda (i e) + (send keymap call-function "hiding:hide-macro" i e))))) + (void)) + + (define/override (on-demand) + (define hiding-panel (send keymap get-hiding-panel)) + (define controller (send keymap get-controller)) + (define stx (send controller get-selected-syntax)) + (define id? (identifier? stx)) + (send show-macro enable id?) + (send hide-macro enable id?) + (super on-demand)) - (super-new))) - - (define stepper-syntax-widget% - (class s:widget% - (init-field macro-stepper) - (inherit get-text) + (super-new))) - (define/override (setup-keymap) - (new stepper-keymap% - (editor (get-text)) - (widget this) - (macro-stepper macro-stepper))) +(define stepper-syntax-widget% + (class s:widget% + (init-field macro-stepper) + (inherit get-text) - (define/override (show-props show?) - (super show-props show?) - (send macro-stepper update/preserve-view)) + (define/override (setup-keymap) + (new stepper-keymap% + (editor (get-text)) + (widget this) + (macro-stepper macro-stepper))) - (super-new - (config (new config-adapter% - (config (send macro-stepper get-config))))))) - - (define config-adapter% - (class object% - (init-field config) - (define/public pref:props-percentage - (case-lambda [() (send config get-props-percentage)] - [(v) (send config set-props-percentage v)])) - (super-new))) - ) + (define/override (show-props show?) + (super show-props show?) + (send macro-stepper update/preserve-view)) + + (super-new + (config (new config-adapter% + (config (send macro-stepper get-config))))))) + +(define config-adapter% + (class object% + (init-field config) + (define/public pref:props-percentage + (case-lambda [() (send config get-props-percentage)] + [(v) (send config set-props-percentage v)])) + (super-new))) diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index f48b51a..3e37b88 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -1,236 +1,234 @@ -(module frame mzscheme - (require (lib "class.ss") - (lib "unit.ss") - (lib "list.ss") - (lib "file.ss") - (lib "plt-match.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - (lib "boundmap.ss" "syntax") - "interfaces.ss" - "stepper.ss" - "prefs.ss" - "warning.ss" - "hiding-panel.ss" - (prefix sb: "../syntax-browser/embed.ss") - (prefix sb: "../syntax-browser/params.ss") - "../model/deriv.ss" - "../model/deriv-util.ss" - "../model/trace.ss" - "../model/hide.ss" - "../model/steps.ss" - "cursor.ss" - "util.ss") - (provide macro-stepper-frame-mixin) +#lang scheme/base +(require scheme/class + scheme/unit + scheme/list + scheme/file + scheme/match + scheme/gui + framework/framework + syntax/boundmap + "interfaces.ss" + "stepper.ss" + "prefs.ss" + "warning.ss" + "hiding-panel.ss" + (prefix-in sb: "../syntax-browser/embed.ss") + (prefix-in sb: "../syntax-browser/params.ss") + "../model/deriv.ss" + "../model/deriv-util.ss" + "../model/trace.ss" + "../model/hide.ss" + "../model/steps.ss" + "cursor.ss" + "../util/notify.ss") +(provide macro-stepper-frame-mixin) - (define (macro-stepper-frame-mixin base-frame%) - (class base-frame% - (init-field config) - (init-field (filename #f)) +(define (macro-stepper-frame-mixin base-frame%) + (class base-frame% + (init-field config) + (init-field (filename #f)) - (define obsoleted? #f) + (define obsoleted? #f) - (inherit get-area-container - set-label - get-menu% - get-menu-item% - get-menu-bar - get-file-menu - get-edit-menu - get-help-menu) + (inherit get-area-container + set-label + get-menu% + get-menu-item% + get-menu-bar + get-file-menu + get-edit-menu + get-help-menu) - (super-new (label (make-label)) - (width (send config get-width)) - (height (send config get-height))) + (super-new (label (make-label)) + (width (send config get-width)) + (height (send config get-height))) - (define/private (make-label) - (if filename - (string-append (path->string - (file-name-from-path filename)) - (if obsoleted? " (old)" "") - " - Macro stepper") - "Macro stepper")) + (define/private (make-label) + (if filename + (string-append (path->string + (file-name-from-path filename)) + (if obsoleted? " (old)" "") + " - Macro stepper") + "Macro stepper")) - (define/override (on-size w h) - (send config set-width w) - (send config set-height h) - (send widget update/preserve-view)) + (define/override (on-size w h) + (send config set-width w) + (send config set-height h) + (send widget update/preserve-view)) - (override/return-false file-menu:create-new? - file-menu:create-open? - file-menu:create-open-recent? - file-menu:create-revert? - file-menu:create-save? - file-menu:create-save-as? - ;file-menu:create-print? - edit-menu:create-undo? - edit-menu:create-redo? - ;edit-menu:create-cut? - ;edit-menu:create-paste? - edit-menu:create-clear? - ;edit-menu:create-find? - ;edit-menu:create-find-again? - edit-menu:create-replace-and-find-again?) + (override/return-false file-menu:create-new? + file-menu:create-open? + file-menu:create-open-recent? + file-menu:create-revert? + file-menu:create-save? + file-menu:create-save-as? + ;file-menu:create-print? + edit-menu:create-undo? + edit-menu:create-redo? + ;edit-menu:create-cut? + ;edit-menu:create-paste? + edit-menu:create-clear? + ;edit-menu:create-find? + ;edit-menu:create-find-again? + edit-menu:create-replace-and-find-again?) - (define file-menu (get-file-menu)) - (define edit-menu (get-edit-menu)) - (define stepper-menu - (new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) - (define help-menu (get-help-menu)) + (define file-menu (get-file-menu)) + (define edit-menu (get-edit-menu)) + (define stepper-menu + (new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) + (define help-menu (get-help-menu)) - (define warning-panel - (new horizontal-panel% - (parent (get-area-container)) - (stretchable-height #f) - (style '(deleted)))) + (define warning-panel + (new horizontal-panel% + (parent (get-area-container)) + (stretchable-height #f) + (style '(deleted)))) - (define/public (get-macro-stepper-widget%) - macro-stepper-widget%) + (define/public (get-macro-stepper-widget%) + macro-stepper-widget%) - (define widget - (new (get-macro-stepper-widget%) - (parent (get-area-container)) - (config config))) + (define widget + (new (get-macro-stepper-widget%) + (parent (get-area-container)) + (config config))) - (define/public (get-widget) widget) + (define/public (get-widget) widget) - (define/public (add-obsoleted-warning) - (unless obsoleted? - (set! obsoleted? #t) - (new warning-canvas% - (warning - (string-append - "Warning: This macro stepper session is obsolete. " - "The program may have changed.")) - (parent warning-panel)) - (set-label (make-label)) - (send (get-area-container) change-children - (lambda (children) - (cons warning-panel - (remq warning-panel children)))))) + (define/public (add-obsoleted-warning) + (unless obsoleted? + (set! obsoleted? #t) + (new warning-canvas% + (warning + (string-append + "Warning: This macro stepper session is obsolete. " + "The program may have changed.")) + (parent warning-panel)) + (set-label (make-label)) + (send (get-area-container) change-children + (lambda (children) + (cons warning-panel + (remq warning-panel children)))))) - ;; Set up menus + ;; Set up menus - (menu-option/notify-box stepper-menu - "Show syntax properties" - (get-field show-syntax-properties? config)) + (menu-option/notify-box stepper-menu + "Show syntax properties" + (get-field show-syntax-properties? config)) - ;; FIXME: rewrite with notify-box - (let ([id-menu - (new (get-menu%) - (label "Identifier=?") - (parent stepper-menu))]) - (for-each (lambda (p) - (let ([this-choice - (new checkable-menu-item% - (label (car p)) - (parent id-menu) - (callback - (lambda _ - (send (send widget get-controller) - set-identifier=? p))))]) - (send (send widget get-controller) - listen-identifier=? - (lambda (name+func) - (send this-choice check - (eq? (car name+func) (car p))))))) - (sb:identifier=-choices))) - (let ([identifier=? (send config get-identifier=?)]) - (when identifier=? - (let ([p (assoc identifier=? (sb:identifier=-choices))]) - (send (send widget get-controller) set-identifier=? p)))) + ;; FIXME: rewrite with notify-box + (let ([id-menu + (new (get-menu%) + (label "Identifier=?") + (parent stepper-menu))]) + (for-each (lambda (p) + (let ([this-choice + (new checkable-menu-item% + (label (car p)) + (parent id-menu) + (callback + (lambda _ + (send (send widget get-controller) + set-identifier=? p))))]) + (send (send widget get-controller) + listen-identifier=? + (lambda (name+func) + (send this-choice check + (eq? (car name+func) (car p))))))) + (sb:identifier=-choices))) + (let ([identifier=? (send config get-identifier=?)]) + (when identifier=? + (let ([p (assoc identifier=? (sb:identifier=-choices))]) + (send (send widget get-controller) set-identifier=? p)))) - (new (get-menu-item%) - (label "Clear selection") - (parent stepper-menu) + (new (get-menu-item%) + (label "Clear selection") + (parent stepper-menu) + (callback + (lambda _ (send (send widget get-controller) select-syntax #f)))) + (new separator-menu-item% (parent stepper-menu)) + + (menu-option/notify-box stepper-menu + "Show macro hiding panel" + (get-field show-hiding-panel? config)) + #; + (new (get-menu-item%) + (label "Show in new frame") + (parent stepper-menu) + (callback (lambda _ (send widget show-in-new-frame)))) + (new (get-menu-item%) + (label "Remove selected term") + (parent stepper-menu) + (callback (lambda _ (send widget remove-current-term)))) + (new (get-menu-item%) + (label "Reset mark numbering") + (parent stepper-menu) + (callback (lambda _ (send widget reset-primary-partition)))) + (let ([extras-menu + (new (get-menu%) + (label "Extra options") + (parent stepper-menu))]) + (new checkable-menu-item% + (label "Always suffix marked identifiers") + (parent extras-menu) (callback - (lambda _ (send (send widget get-controller) select-syntax #f)))) - (new separator-menu-item% (parent stepper-menu)) + (lambda (i e) + (sb:current-suffix-option + (if (send i is-checked?) + 'always + 'over-limit)) + (send widget update/preserve-view)))) + (menu-option/notify-box extras-menu + "Highlight redex/contractum" + (get-field highlight-foci? config)) + (menu-option/notify-box extras-menu + "Highlight frontier" + (get-field highlight-frontier? config)) + (menu-option/notify-box extras-menu + "Include renaming steps" + (get-field show-rename-steps? config)) + (menu-option/notify-box extras-menu + "One term at a time" + (get-field one-by-one? config)) + (menu-option/notify-box extras-menu + "Suppress warnings" + (get-field suppress-warnings? config)) + (menu-option/notify-box extras-menu + "Extra navigation" + (get-field extra-navigation? config)) + (menu-option/notify-box extras-menu + "Force block->letrec transformation" + (get-field force-letrec-transformation? config)) + (menu-option/notify-box extras-menu + "(Debug) Catch internal errors?" + (get-field debug-catch-errors? config))) - (menu-option/notify-box stepper-menu - "Show macro hiding panel" - (get-field show-hiding-panel? config)) - #; - (new (get-menu-item%) - (label "Show in new frame") - (parent stepper-menu) - (callback (lambda _ (send widget show-in-new-frame)))) - (new (get-menu-item%) - (label "Remove selected term") - (parent stepper-menu) - (callback (lambda _ (send widget remove-current-term)))) - (new (get-menu-item%) - (label "Reset mark numbering") - (parent stepper-menu) - (callback (lambda _ (send widget reset-primary-partition)))) - (let ([extras-menu - (new (get-menu%) - (label "Extra options") - (parent stepper-menu))]) - (new checkable-menu-item% - (label "Always suffix marked identifiers") - (parent extras-menu) - (callback - (lambda (i e) - (sb:current-suffix-option - (if (send i is-checked?) - 'always - 'over-limit)) - (send widget update/preserve-view)))) - (menu-option/notify-box extras-menu - "Highlight redex/contractum" - (get-field highlight-foci? config)) - (menu-option/notify-box extras-menu - "Highlight frontier" - (get-field highlight-frontier? config)) - (menu-option/notify-box extras-menu - "Include renaming steps" - (get-field show-rename-steps? config)) - (menu-option/notify-box extras-menu - "One term at a time" - (get-field one-by-one? config)) - (menu-option/notify-box extras-menu - "Suppress warnings" - (get-field suppress-warnings? config)) - (menu-option/notify-box extras-menu - "Extra navigation" - (get-field extra-navigation? config)) - (menu-option/notify-box extras-menu - "Force block->letrec transformation" - (get-field force-letrec-transformation? config)) - (menu-option/notify-box extras-menu - "(Debug) Catch internal errors?" - (get-field debug-catch-errors? config))) + (frame:reorder-menus this))) - (frame:reorder-menus this))) +;; Stolen from stepper - ;; Stolen from stepper +(define warning-color "yellow") +(define warning-font normal-control-font) - (define warning-color "yellow") - (define warning-font normal-control-font) - - (define warning-canvas% - (class canvas% - (init-field warning) - (inherit get-dc get-client-size) - (define/override (on-paint) - (let ([dc (get-dc)]) - (send dc set-font warning-font) - (let-values ([(cw ch) (get-client-size)] - [(tw th dont-care dont-care2) (send dc get-text-extent warning)]) - (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid)) - (send dc draw-rectangle 0 0 cw ch) - (send dc draw-text - warning - (- (/ cw 2) (/ tw 2)) - (- (/ ch 2) (/ th 2)))))) - (super-new) - (inherit min-width min-height stretchable-height) - (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)]) - (min-width (+ 2 (inexact->exact (ceiling tw)))) - (min-height (+ 2 (inexact->exact (ceiling th))))) - (stretchable-height #f))) - - ) +(define warning-canvas% + (class canvas% + (init-field warning) + (inherit get-dc get-client-size) + (define/override (on-paint) + (let ([dc (get-dc)]) + (send dc set-font warning-font) + (let-values ([(cw ch) (get-client-size)] + [(tw th dont-care dont-care2) (send dc get-text-extent warning)]) + (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid)) + (send dc draw-rectangle 0 0 cw ch) + (send dc draw-text + warning + (- (/ cw 2) (/ tw 2)) + (- (/ ch 2) (/ th 2)))))) + (super-new) + (inherit min-width min-height stretchable-height) + (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)]) + (min-width (+ 2 (inexact->exact (ceiling tw)))) + (min-height (+ 2 (inexact->exact (ceiling th))))) + (stretchable-height #f))) diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index 3d6fa84..2b62c2b 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -1,320 +1,319 @@ -(module hiding-panel mzscheme - (require (lib "class.ss") - (lib "mred.ss" "mred") - (lib "list.ss") - (lib "boundmap.ss" "syntax") - "util.ss" - "../model/synth-engine.ss" - "../syntax-browser/util.ss" - "../util/hiding.ss") - (provide macro-hiding-prefs-widget%) +#lang scheme/base +(require scheme/class + scheme/gui + scheme/list + syntax/boundmap + "../model/synth-engine.ss" + "../syntax-browser/util.ss" + "../util/notify.ss" + "../util/hiding.ss") +(provide macro-hiding-prefs-widget%) - (define mode:disable "Disable") - (define mode:standard "Standard") - (define mode:custom "Custom ...") +(define mode:disable "Disable") +(define mode:standard "Standard") +(define mode:custom "Custom ...") - (define (make-policy hide-mzscheme? - hide-libs? - hide-contracts? - hide-transformers? - specialized-policies) - (lambda (id) - (define now (phase)) - (define binding - (cond [(= now 0) (identifier-binding id)] - [(= now 1) (identifier-transformer-binding id)] - [else #f])) - (define-values (def-mod def-name nom-mod nom-name) - (if (pair? binding) - (values (car binding) - (cadr binding) - (caddr binding) - (cadddr binding)) - (values #f #f #f #f))) - (let/ec return - (let loop ([policies specialized-policies]) - (when (pair? policies) - ((car policies) id binding return) - (loop (cdr policies)))) - (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod)) - #f] - [(and hide-libs? def-mod (lib-module? def-mod)) - #f] - [(and hide-contracts? def-name - (regexp-match #rx"^provide/contract-id-" - (symbol->string def-name))) - #f] - [(and hide-transformers? (positive? now)) - #f] - [else #t])))) +(define (make-policy hide-mzscheme? + hide-libs? + hide-contracts? + hide-transformers? + specialized-policies) + (lambda (id) + (define now (phase)) + (define binding + (cond [(= now 0) (identifier-binding id)] + [(= now 1) (identifier-transformer-binding id)] + [else #f])) + (define-values (def-mod def-name nom-mod nom-name) + (if (pair? binding) + (values (car binding) + (cadr binding) + (caddr binding) + (cadddr binding)) + (values #f #f #f #f))) + (let/ec return + (let loop ([policies specialized-policies]) + (when (pair? policies) + ((car policies) id binding return) + (loop (cdr policies)))) + (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod)) + #f] + [(and hide-libs? def-mod (lib-module? def-mod)) + #f] + [(and hide-contracts? def-name + (regexp-match #rx"^provide/contract-id-" + (symbol->string def-name))) + #f] + [(and hide-transformers? (positive? now)) + #f] + [else #t])))) - (define standard-policy - (make-policy #t #t #t #t null)) +(define standard-policy + (make-policy #t #t #t #t null)) - ;; macro-hiding-prefs-widget% - (define macro-hiding-prefs-widget% - (class object% - (init parent) - (init-field stepper) - (init-field config) +;; macro-hiding-prefs-widget% +(define macro-hiding-prefs-widget% + (class object% + (init parent) + (init-field stepper) + (init-field config) - (define/public (get-policy) - (let ([mode (get-mode)]) - (cond [(not (macro-hiding-enabled?)) #f] - [(equal? mode mode:standard) standard-policy] - [(equal? mode mode:custom) (get-custom-policy)]))) + (define/public (get-policy) + (let ([mode (get-mode)]) + (cond [(not (macro-hiding-enabled?)) #f] + [(equal? mode mode:standard) standard-policy] + [(equal? mode mode:custom) (get-custom-policy)]))) - (define/private (get-custom-policy) - (let ([hide-mzscheme? (send box:hide-mzscheme get-value)] - [hide-libs? (send box:hide-libs get-value)] - [hide-contracts? (send box:hide-contracts get-value)] - [hide-transformers? (send box:hide-phase1 get-value)] - [specialized-policies (get-specialized-policies)]) - (make-policy hide-mzscheme? - hide-libs? - hide-contracts? - hide-transformers? - specialized-policies))) + (define/private (get-custom-policy) + (let ([hide-mzscheme? (send box:hide-mzscheme get-value)] + [hide-libs? (send box:hide-libs get-value)] + [hide-contracts? (send box:hide-contracts get-value)] + [hide-transformers? (send box:hide-phase1 get-value)] + [specialized-policies (get-specialized-policies)]) + (make-policy hide-mzscheme? + hide-libs? + hide-contracts? + hide-transformers? + specialized-policies))) - (define super-panel - (new vertical-panel% - (parent parent) - (stretchable-height #f))) - (define top-line-panel - (new horizontal-panel% - (parent super-panel) - (alignment '(left center)) - (stretchable-height #f))) - (define customize-panel - (new horizontal-panel% - (parent super-panel) - (stretchable-height #f) - (alignment '(left top)) - (style '(deleted)))) - (define left-pane - (new vertical-pane% - (parent customize-panel) - (stretchable-width #f) - (alignment '(left top)))) - (define right-pane - (new vertical-pane% - (parent customize-panel))) + (define super-panel + (new vertical-panel% + (parent parent) + (stretchable-height #f))) + (define top-line-panel + (new horizontal-panel% + (parent super-panel) + (alignment '(left center)) + (stretchable-height #f))) + (define customize-panel + (new horizontal-panel% + (parent super-panel) + (stretchable-height #f) + (alignment '(left top)) + (style '(deleted)))) + (define left-pane + (new vertical-pane% + (parent customize-panel) + (stretchable-width #f) + (alignment '(left top)))) + (define right-pane + (new vertical-pane% + (parent customize-panel))) - (define mode-selector - (choice/notify-box - top-line-panel - "Macro hiding: " - (list mode:disable mode:standard mode:custom) - (get-field macro-hiding-mode config))) - (define top-line-inner-panel - (new horizontal-panel% - (parent top-line-panel) - (alignment '(right center)) - (style '(deleted)))) + (define mode-selector + (choice/notify-box + top-line-panel + "Macro hiding: " + (list mode:disable mode:standard mode:custom) + (get-field macro-hiding-mode config))) + (define top-line-inner-panel + (new horizontal-panel% + (parent top-line-panel) + (alignment '(right center)) + (style '(deleted)))) - (define/private (get-mode) - (send config get-macro-hiding-mode)) + (define/private (get-mode) + (send config get-macro-hiding-mode)) - (define/private (macro-hiding-enabled?) - (let ([mode (get-mode)]) - (or (equal? mode mode:standard) - (and (equal? mode mode:custom) - (send box:hiding get-value))))) + (define/private (macro-hiding-enabled?) + (let ([mode (get-mode)]) + (or (equal? mode mode:standard) + (and (equal? mode mode:custom) + (send box:hiding get-value))))) - (define/private (ensure-custom-mode) - (unless (equal? (get-mode) mode:custom) - (send config set-macro-hiding-mode mode:custom))) + (define/private (ensure-custom-mode) + (unless (equal? (get-mode) mode:custom) + (send config set-macro-hiding-mode mode:custom))) - (define/private (update-visibility) - (let ([customizing (equal? (get-mode) mode:custom)]) - (send top-line-panel change-children - (lambda (children) - (append (remq top-line-inner-panel children) - (if customizing (list top-line-inner-panel) null)))) - (send super-panel change-children - (lambda (children) - (append (remq customize-panel children) - (if (and customizing (send box:edit get-value)) - (list customize-panel) - null)))))) + (define/private (update-visibility) + (let ([customizing (equal? (get-mode) mode:custom)]) + (send top-line-panel change-children + (lambda (children) + (append (remq top-line-inner-panel children) + (if customizing (list top-line-inner-panel) null)))) + (send super-panel change-children + (lambda (children) + (append (remq customize-panel children) + (if (and customizing (send box:edit get-value)) + (list customize-panel) + null)))))) - (send config listen-macro-hiding-mode - (lambda (value) - (update-visibility) - (force-refresh))) + (send config listen-macro-hiding-mode + (lambda (value) + (update-visibility) + (force-refresh))) - (define box:hiding - (new check-box% - (label "Enable macro hiding") - (value #t) - (parent top-line-inner-panel) - (callback (lambda (c e) (force-refresh))))) - (define box:edit - (new check-box% - (label "Show policy editor") - (parent top-line-inner-panel) - (value #t) - (callback (lambda (c e) (update-visibility))))) + (define box:hiding + (new check-box% + (label "Enable macro hiding") + (value #t) + (parent top-line-inner-panel) + (callback (lambda (c e) (force-refresh))))) + (define box:edit + (new check-box% + (label "Show policy editor") + (parent top-line-inner-panel) + (value #t) + (callback (lambda (c e) (update-visibility))))) - (define box:hide-mzscheme - (new check-box% - (label "Hide mzscheme syntax") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) - (define box:hide-libs - (new check-box% - (label "Hide library syntax") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) - (define box:hide-contracts - (new check-box% - (label "Hide contracts (heuristic)") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) - (define box:hide-phase1 - (new check-box% - (label "Hide phase>0") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) + (define box:hide-mzscheme + (new check-box% + (label "Hide mzscheme syntax") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) + (define box:hide-libs + (new check-box% + (label "Hide library syntax") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) + (define box:hide-contracts + (new check-box% + (label "Hide contracts (heuristic)") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) + (define box:hide-phase1 + (new check-box% + (label "Hide phase>0") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) - (define look-ctl - (new list-box% (parent right-pane) (label "") - (choices null) (style '(extended)) - (callback - (lambda (c e) - (send delete-ctl enable (pair? (send c get-selections))))))) + (define look-ctl + (new list-box% (parent right-pane) (label "") + (choices null) (style '(extended)) + (callback + (lambda (c e) + (send delete-ctl enable (pair? (send c get-selections))))))) - (define look-button-pane - (new horizontal-pane% (parent right-pane) (stretchable-width #f))) + (define look-button-pane + (new horizontal-pane% (parent right-pane) (stretchable-width #f))) - (define delete-ctl - (new button% (parent look-button-pane) (label "Delete rule") (enabled #f) - (callback (lambda _ (delete-selected) (refresh))))) - (define add-hide-id-button - (new button% (parent look-button-pane) (label "Hide macro") (enabled #f) - (callback (lambda _ (add-hide-identifier) (refresh))))) - (define add-show-id-button - (new button% (parent look-button-pane) (label "Show macro") (enabled #f) - (callback (lambda _ (add-show-identifier) (refresh))))) - #;(new grow-box-spacer-pane% (parent right-pane)) + (define delete-ctl + (new button% (parent look-button-pane) (label "Delete rule") (enabled #f) + (callback (lambda _ (delete-selected) (refresh))))) + (define add-hide-id-button + (new button% (parent look-button-pane) (label "Hide macro") (enabled #f) + (callback (lambda _ (add-hide-identifier) (refresh))))) + (define add-show-id-button + (new button% (parent look-button-pane) (label "Show macro") (enabled #f) + (callback (lambda _ (add-show-identifier) (refresh))))) + #;(new grow-box-spacer-pane% (parent right-pane)) - ;; Methods + ;; Methods - (define stx #f) - (define stx-name #f) + (define stx #f) + (define stx-name #f) - ;; refresh : -> void - (define/public (refresh) - (when (macro-hiding-enabled?) - (send stepper refresh/resynth))) + ;; refresh : -> void + (define/public (refresh) + (when (macro-hiding-enabled?) + (send stepper refresh/resynth))) - ;; force-refresh : -> void - (define/private (force-refresh) - (send stepper refresh/resynth)) + ;; force-refresh : -> void + (define/private (force-refresh) + (send stepper refresh/resynth)) - ;; set-syntax : syntax/#f -> void - (define/public (set-syntax lstx) - (set! stx (and (identifier? lstx) lstx)) - (when (identifier? stx) - (let ([binding (identifier-binding stx)]) - (if (pair? binding) - (set! stx-name (cadr binding)) - (set! stx-name (syntax-e stx))))) - (send add-show-id-button enable (identifier? lstx)) - (send add-hide-id-button enable (identifier? lstx))) + ;; set-syntax : syntax/#f -> void + (define/public (set-syntax lstx) + (set! stx (and (identifier? lstx) lstx)) + (when (identifier? stx) + (let ([binding (identifier-binding stx)]) + (if (pair? binding) + (set! stx-name (cadr binding)) + (set! stx-name (syntax-e stx))))) + (send add-show-id-button enable (identifier? lstx)) + (send add-hide-id-button enable (identifier? lstx))) - (define identifier-policies null) + (define identifier-policies null) - (define/private (get-specialized-policies) - (map (lambda (policy) - (define key (mcar policy)) - (define show? (mcdr policy)) - (cond [(pair? key) - (lambda (id binding return) - (when (and (pair? binding) - (equal? key (get-id-key/binding id binding))) - (return show?)))] - [else - (lambda (id binding return) - (when (module-identifier=? id key) - (return show?)))])) - identifier-policies)) + (define/private (get-specialized-policies) + (map (lambda (policy) + (define key (mcar policy)) + (define show? (mcdr policy)) + (cond [(pair? key) + (lambda (id binding return) + (when (and (pair? binding) + (equal? key (get-id-key/binding id binding))) + (return show?)))] + [else + (lambda (id binding return) + (when (free-identifier=? id key) + (return show?)))])) + identifier-policies)) - (define/public (add-hide-identifier) - (add-identifier-policy #f) - (ensure-custom-mode)) + (define/public (add-hide-identifier) + (add-identifier-policy #f) + (ensure-custom-mode)) - (define/public (add-show-identifier) - (add-identifier-policy #t) - (ensure-custom-mode)) + (define/public (add-show-identifier) + (add-identifier-policy #t) + (ensure-custom-mode)) - (define/private (add-identifier-policy show?) - (when (identifier? stx) - (let ([key (get-id-key stx)]) - (let loop ([i 0] [policies identifier-policies]) - (cond [(null? policies) - (set! identifier-policies - (cons (mcons key show?) identifier-policies)) - (send look-ctl append "") - (update-list-view i key show?)] - [(key=? key (mcar (car policies))) - (set-mcdr! (car policies) show?) - (update-list-view i key show?)] - [else (loop (add1 i) (cdr policies))]))))) + (define/private (add-identifier-policy show?) + (when (identifier? stx) + (let ([key (get-id-key stx)]) + (let loop ([i 0] [policies identifier-policies]) + (cond [(null? policies) + (set! identifier-policies + (cons (mcons key show?) identifier-policies)) + (send look-ctl append "") + (update-list-view i key show?)] + [(key=? key (mcar (car policies))) + (set-mcdr! (car policies) show?) + (update-list-view i key show?)] + [else (loop (add1 i) (cdr policies))]))))) - (define/private (update-list-view index key show?) - (send look-ctl set-data index key) - (send look-ctl set-string - index - (string-append (if show? "show " "hide ") - (key->text key)))) + (define/private (update-list-view index key show?) + (send look-ctl set-data index key) + (send look-ctl set-string + index + (string-append (if show? "show " "hide ") + (key->text key)))) - (define/private (delete-selected) - (define to-delete (sort (send look-ctl get-selections) <)) - (set! identifier-policies - (let loop ([i 0] [policies identifier-policies] [to-delete to-delete]) - (cond [(null? to-delete) policies] - [(= i (car to-delete)) - (loop (add1 i) (cdr policies) (cdr to-delete))] - [else - (cons (car policies) - (loop (add1 i) (cdr policies) to-delete))]))) - (for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete))) + (define/private (delete-selected) + (define to-delete (sort (send look-ctl get-selections) <)) + (set! identifier-policies + (let loop ([i 0] [policies identifier-policies] [to-delete to-delete]) + (cond [(null? to-delete) policies] + [(= i (car to-delete)) + (loop (add1 i) (cdr policies) (cdr to-delete))] + [else + (cons (car policies) + (loop (add1 i) (cdr policies) to-delete))]))) + (for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete))) - (super-new) - (update-visibility))) + (super-new) + (update-visibility))) - (define (get-id-key id) - id - #; ;; FIXME - (let ([binding (identifier-binding id)]) - (get-id-key/binding id binding))) +(define (get-id-key id) + id + #; ;; FIXME + (let ([binding (identifier-binding id)]) + (get-id-key/binding id binding))) - (define (get-id-key/binding id binding) - (cond [(pair? binding) - (list (car binding) (cadr binding))] - [else id])) +(define (get-id-key/binding id binding) + (cond [(pair? binding) + (list (car binding) (cadr binding))] + [else id])) - (define (key=? key1 key2) - (cond [(and (identifier? key1) (identifier? key2)) - (module-identifier=? key1 key2)] - [(and (pair? key1) (pair? key2)) - (and (equal? (car key1) (car key2)) - (equal? (cadr key1) (cadr key2)))] - [else #f])) +(define (key=? key1 key2) + (cond [(and (identifier? key1) (identifier? key2)) + (free-identifier=? key1 key2)] + [(and (pair? key1) (pair? key2)) + (and (equal? (car key1) (car key2)) + (equal? (cadr key1) (cadr key2)))] + [else #f])) - (define (key->text key) - (cond [(pair? key) - (let ([name (cadddr key)] - [mod (caddr key)]) - (format "'~s' from ~a" - name - (mpi->string mod)))] - [else (symbol->string (syntax-e key))])) +(define (key->text key) + (cond [(pair? key) + (let ([name (cadddr key)] + [mod (caddr key)]) + (format "'~s' from ~a" + name + (mpi->string mod)))] + [else (symbol->string (syntax-e key))])) - ) diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss index 855dd1d..c0a9ade 100644 --- a/collects/macro-debugger/view/interfaces.ss +++ b/collects/macro-debugger/view/interfaces.ss @@ -1,48 +1,46 @@ -(module interfaces mzscheme - (require (lib "unit.ss")) - (provide (all-defined)) - - ;; Signatures +#lang scheme/base +(require scheme/unit) +(provide (all-defined-out)) - (define-signature view^ - (macro-stepper-frame% - macro-stepper-widget% - make-macro-stepper - go - go/deriv)) +;; Signatures - (define-signature view-base^ - (base-frame%)) +(define-signature view^ + (macro-stepper-frame% + macro-stepper-widget% + make-macro-stepper + go + go/deriv)) - (define-signature prefs^ - (pref:width - pref:height - pref:props-percentage - pref:macro-hiding-mode - pref:show-syntax-properties? - pref:show-hiding-panel? - pref:identifier=? - pref:show-rename-steps? - pref:highlight-foci? - pref:highlight-frontier? - pref:suppress-warnings? - pref:one-by-one? - pref:extra-navigation? - pref:debug-catch-errors? - pref:force-letrec-transformation? - )) +(define-signature view-base^ + (base-frame%)) - ;; macro-stepper-config% - ;; all fields are notify-box% objects - ;; width - ;; height - ;; macro-hiding? - ;; hide-primitives? - ;; hide-libs? - ;; show-syntax-properties? - ;; show-hiding-panel? - ;; show-rename-steps? - ;; highlight-foci? +(define-signature prefs^ + (pref:width + pref:height + pref:props-percentage + pref:macro-hiding-mode + pref:show-syntax-properties? + pref:show-hiding-panel? + pref:identifier=? + pref:show-rename-steps? + pref:highlight-foci? + pref:highlight-frontier? + pref:suppress-warnings? + pref:one-by-one? + pref:extra-navigation? + pref:debug-catch-errors? + pref:force-letrec-transformation? + )) - ) +;; macro-stepper-config% +;; all fields are notify-box% objects +;; width +;; height +;; macro-hiding? +;; hide-primitives? +;; hide-libs? +;; show-syntax-properties? +;; show-hiding-panel? +;; show-rename-steps? +;; highlight-foci? diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss index f7bbcb8..10a25b2 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -1,100 +1,98 @@ -(module prefs mzscheme - (require (lib "class.ss") - (lib "framework.ss" "framework") - "../util/notify.ss" - "../util/misc.ss") - (provide macro-stepper-config-base% - macro-stepper-config/prefs% - macro-stepper-config/prefs/readonly%) +#lang scheme/base +(require scheme/class + framework/framework + "../util/notify.ss" + "../util/misc.ss") +(provide macro-stepper-config-base% + macro-stepper-config/prefs% + macro-stepper-config/prefs/readonly%) - (preferences:set-default 'MacroStepper:Frame:Width 700 number?) - (preferences:set-default 'MacroStepper:Frame:Height 600 number?) - (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) - (preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?) - (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) - (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) - (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) - (preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?) - (preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?) - (preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?) - (preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?) - (preferences:set-default 'MacroStepper:OneByOne? #f boolean?) - (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?) - (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?) - (preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?) +(preferences:set-default 'MacroStepper:Frame:Width 700 number?) +(preferences:set-default 'MacroStepper:Frame:Height 600 number?) +(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) +(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?) +(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) +(preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) +(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) +(preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?) +(preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?) +(preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?) +(preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?) +(preferences:set-default 'MacroStepper:OneByOne? #f boolean?) +(preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?) +(preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?) +(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?) - (pref:get/set pref:width MacroStepper:Frame:Width) - (pref:get/set pref:height MacroStepper:Frame:Height) - (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage) - (pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode) - (pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?) - (pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?) - (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison) - (pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?) - (pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?) - (pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?) - (pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?) - (pref:get/set pref:one-by-one? MacroStepper:OneByOne?) - (pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?) - (pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?) - (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) +(pref:get/set pref:width MacroStepper:Frame:Width) +(pref:get/set pref:height MacroStepper:Frame:Height) +(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage) +(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode) +(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?) +(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?) +(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison) +(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?) +(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?) +(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?) +(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?) +(pref:get/set pref:one-by-one? MacroStepper:OneByOne?) +(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?) +(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?) +(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) - (define macro-stepper-config-base% - (class object% - (notify-methods width) - (notify-methods height) - (notify-methods macro-hiding-mode) - (notify-methods props-percentage) - (notify-methods show-syntax-properties?) - (notify-methods show-hiding-panel?) - (notify-methods identifier=?) - (notify-methods highlight-foci?) - (notify-methods highlight-frontier?) - (notify-methods show-rename-steps?) - (notify-methods suppress-warnings?) - (notify-methods one-by-one?) - (notify-methods extra-navigation?) - (notify-methods debug-catch-errors?) - (notify-methods force-letrec-transformation?) - (super-new))) +(define macro-stepper-config-base% + (class object% + (notify-methods width) + (notify-methods height) + (notify-methods macro-hiding-mode) + (notify-methods props-percentage) + (notify-methods show-syntax-properties?) + (notify-methods show-hiding-panel?) + (notify-methods identifier=?) + (notify-methods highlight-foci?) + (notify-methods highlight-frontier?) + (notify-methods show-rename-steps?) + (notify-methods suppress-warnings?) + (notify-methods one-by-one?) + (notify-methods extra-navigation?) + (notify-methods debug-catch-errors?) + (notify-methods force-letrec-transformation?) + (super-new))) - (define macro-stepper-config/prefs% - (class macro-stepper-config-base% - (connect-to-pref width pref:width) - (connect-to-pref height pref:height) - (connect-to-pref macro-hiding-mode pref:macro-hiding-mode) - (connect-to-pref props-percentage pref:props-percentage) - (connect-to-pref show-syntax-properties? pref:show-syntax-properties?) - (connect-to-pref show-hiding-panel? pref:show-hiding-panel?) - (connect-to-pref identifier=? pref:identifier=?) - (connect-to-pref highlight-foci? pref:highlight-foci?) - (connect-to-pref highlight-frontier? pref:highlight-frontier?) - (connect-to-pref show-rename-steps? pref:show-rename-steps?) - (connect-to-pref suppress-warnings? pref:suppress-warnings?) - (connect-to-pref one-by-one? pref:one-by-one?) - (connect-to-pref extra-navigation? pref:extra-navigation?) - (connect-to-pref debug-catch-errors? pref:debug-catch-errors?) - (connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?) - (super-new))) +(define macro-stepper-config/prefs% + (class macro-stepper-config-base% + (connect-to-pref width pref:width) + (connect-to-pref height pref:height) + (connect-to-pref macro-hiding-mode pref:macro-hiding-mode) + (connect-to-pref props-percentage pref:props-percentage) + (connect-to-pref show-syntax-properties? pref:show-syntax-properties?) + (connect-to-pref show-hiding-panel? pref:show-hiding-panel?) + (connect-to-pref identifier=? pref:identifier=?) + (connect-to-pref highlight-foci? pref:highlight-foci?) + (connect-to-pref highlight-frontier? pref:highlight-frontier?) + (connect-to-pref show-rename-steps? pref:show-rename-steps?) + (connect-to-pref suppress-warnings? pref:suppress-warnings?) + (connect-to-pref one-by-one? pref:one-by-one?) + (connect-to-pref extra-navigation? pref:extra-navigation?) + (connect-to-pref debug-catch-errors? pref:debug-catch-errors?) + (connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?) + (super-new))) - (define macro-stepper-config/prefs/readonly% - (class macro-stepper-config-base% - (connect-to-pref/readonly width pref:width) - (connect-to-pref/readonly height pref:height) - (connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode) - (connect-to-pref/readonly props-percentage pref:props-percentage) - (connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?) - (connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?) - (connect-to-pref/readonly identifier=? pref:identifier=?) - (connect-to-pref/readonly highlight-foci? pref:highlight-foci?) - (connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?) - (connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?) - (connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?) - (connect-to-pref/readonly one-by-one? pref:one-by-one?) - (connect-to-pref/readonly extra-navigation? pref:extra-navigation?) - (connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?) - (connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?) - (super-new))) - - ) +(define macro-stepper-config/prefs/readonly% + (class macro-stepper-config-base% + (connect-to-pref/readonly width pref:width) + (connect-to-pref/readonly height pref:height) + (connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode) + (connect-to-pref/readonly props-percentage pref:props-percentage) + (connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?) + (connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?) + (connect-to-pref/readonly identifier=? pref:identifier=?) + (connect-to-pref/readonly highlight-foci? pref:highlight-foci?) + (connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?) + (connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?) + (connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?) + (connect-to-pref/readonly one-by-one? pref:one-by-one?) + (connect-to-pref/readonly extra-navigation? pref:extra-navigation?) + (connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?) + (connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?) + (super-new))) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 0a161b4..266a818 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -1,433 +1,432 @@ -(module stepper mzscheme - (require (lib "class.ss") - (lib "unit.ss") - (lib "list.ss") - (lib "plt-match.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - (lib "boundmap.ss" "syntax") - "interfaces.ss" - "prefs.ss" - "extensions.ss" - "warning.ss" - "hiding-panel.ss" - "term-record.ss" - (prefix s: "../syntax-browser/widget.ss") - (prefix s: "../syntax-browser/params.ss") - "../model/deriv.ss" - "../model/deriv-util.ss" - "../model/deriv-find.ss" - "../model/trace.ss" - "../model/reductions.ss" - "../model/hide.ss" - "../model/steps.ss" - "cursor.ss" - "util.ss") - (provide macro-stepper-widget% - macro-stepper-widget/process-mixin) +#lang scheme/base +(require scheme/class + scheme/unit + scheme/list + scheme/match + scheme/gui + framework/framework + syntax/boundmap + "interfaces.ss" + "prefs.ss" + "extensions.ss" + "warning.ss" + "hiding-panel.ss" + "term-record.ss" + (prefix-in s: "../syntax-browser/widget.ss") + (prefix-in s: "../syntax-browser/params.ss") + "../model/deriv.ss" + "../model/deriv-util.ss" + "../model/deriv-find.ss" + "../model/trace.ss" + "../model/reductions.ss" + "../model/hide.ss" + "../model/steps.ss" + "cursor.ss" + "../util/notify.ss") +(provide macro-stepper-widget% + macro-stepper-widget/process-mixin) - ;; Macro Stepper +;; Macro Stepper - ;; macro-stepper-widget% - (define macro-stepper-widget% - (class* object% () - (init-field parent) - (init-field config) +;; macro-stepper-widget% +(define macro-stepper-widget% + (class* object% () + (init-field parent) + (init-field config) - ;; Terms + ;; Terms - ;; all-terms : (list-of TermRecord) - ;; (Reversed) - (define all-terms null) + ;; all-terms : (list-of TermRecord) + ;; (Reversed) + (define all-terms null) - ;; terms : (Cursor-of TermRecord) - ;; Contains visible terms of all-terms - (define terms (cursor:new null)) + ;; terms : (Cursor-of TermRecord) + ;; Contains visible terms of all-terms + (define terms (cursor:new null)) - ;; focused-term : -> TermRecord or #f - (define (focused-term) - (cursor:next terms)) + ;; focused-term : -> TermRecord or #f + (define (focused-term) + (cursor:next terms)) - ;; add-deriv : Deriv -> void - (define/public (add-deriv d) - (let ([trec (new term-record% (stepper this) (raw-deriv d))]) - (add trec))) + ;; add-deriv : Deriv -> void + (define/public (add-deriv d) + (let ([trec (new term-record% (stepper this) (raw-deriv d))]) + (add trec))) - ;; add-trace : (list-of event) -> void - (define/public (add-trace events) - (let ([trec (new term-record% (stepper this) (events events))]) - (add trec))) + ;; add-trace : (list-of event) -> void + (define/public (add-trace events) + (let ([trec (new term-record% (stepper this) (events events))]) + (add trec))) - ;; add : TermRecord -> void - (define/public (add trec) - (set! all-terms (cons trec all-terms)) - (let ([display-new-term? (cursor:at-end? terms)] - [invisible? (send trec get-deriv-hidden?)]) - (unless invisible? - (cursor:add-to-end! terms (list trec)) - (trim-navigator) - (if display-new-term? - (refresh) - (update))))) + ;; add : TermRecord -> void + (define/public (add trec) + (set! all-terms (cons trec all-terms)) + (let ([display-new-term? (cursor:at-end? terms)] + [invisible? (send trec get-deriv-hidden?)]) + (unless invisible? + (cursor:add-to-end! terms (list trec)) + (trim-navigator) + (if display-new-term? + (refresh) + (update))))) - ;; remove-current-term : -> void - (define/public (remove-current-term) - (cursor:remove-current! terms) - (trim-navigator) - (refresh)) + ;; remove-current-term : -> void + (define/public (remove-current-term) + (cursor:remove-current! terms) + (trim-navigator) + (refresh)) - (define/public (get-config) config) - (define/public (get-controller) sbc) - (define/public (get-view) sbview) - (define/public (get-warnings-area) warnings-area) - (define/public (get-macro-hiding-prefs) macro-hiding-prefs) + (define/public (get-config) config) + (define/public (get-controller) sbc) + (define/public (get-view) sbview) + (define/public (get-warnings-area) warnings-area) + (define/public (get-macro-hiding-prefs) macro-hiding-prefs) - (define/public (reset-primary-partition) - (send sbc reset-primary-partition) - (update/preserve-view)) + (define/public (reset-primary-partition) + (send sbc reset-primary-partition) + (update/preserve-view)) - (define area (new vertical-panel% (parent parent))) - (define supernavigator - (new horizontal-panel% - (parent area) - (stretchable-height #f) - (alignment '(center center)))) - (define navigator - (new horizontal-panel% - (parent supernavigator) - (stretchable-width #f) - (stretchable-height #f) - (alignment '(left center)))) - (define extra-navigator - (new horizontal-panel% - (parent supernavigator) - (stretchable-width #f) - (stretchable-height #f) - (alignment '(left center)) - (style '(deleted)))) + (define area (new vertical-panel% (parent parent))) + (define supernavigator + (new horizontal-panel% + (parent area) + (stretchable-height #f) + (alignment '(center center)))) + (define navigator + (new horizontal-panel% + (parent supernavigator) + (stretchable-width #f) + (stretchable-height #f) + (alignment '(left center)))) + (define extra-navigator + (new horizontal-panel% + (parent supernavigator) + (stretchable-width #f) + (stretchable-height #f) + (alignment '(left center)) + (style '(deleted)))) + + (define warnings-area (new stepper-warnings% (parent area))) + + (define sbview (new stepper-syntax-widget% + (parent area) + (macro-stepper this))) + (define sbc (send sbview get-controller)) + (define control-pane + (new vertical-panel% (parent area) (stretchable-height #f))) + (define macro-hiding-prefs + (new macro-hiding-prefs-widget% + (parent control-pane) + (stepper this) + (config config))) + + (send config listen-show-syntax-properties? + (lambda (show?) (send sbview show-props show?))) + (send config listen-show-hiding-panel? + (lambda (show?) (show-macro-hiding-prefs show?))) + (send sbc listen-selected-syntax + (lambda (stx) (send macro-hiding-prefs set-syntax stx))) + (send config listen-highlight-foci? + (lambda (_) (update/preserve-view))) + (send config listen-highlight-frontier? + (lambda (_) (update/preserve-view))) + (send config listen-show-rename-steps? + (lambda (_) (refresh/re-reduce))) + (send config listen-one-by-one? + (lambda (_) (refresh/re-reduce))) + (send config listen-force-letrec-transformation? + (lambda (_) (refresh/resynth))) + (send config listen-extra-navigation? + (lambda (show?) (show-extra-navigation show?))) + + (define nav:up + (new button% (label "Previous term") (parent navigator) + (callback (lambda (b e) (navigate-up))))) + (define nav:start + (new button% (label "<-- Start") (parent navigator) + (callback (lambda (b e) (navigate-to-start))))) + (define nav:previous + (new button% (label "<- Step") (parent navigator) + (callback (lambda (b e) (navigate-previous))))) + (define nav:next + (new button% (label "Step ->") (parent navigator) + (callback (lambda (b e) (navigate-next))))) + (define nav:end + (new button% (label "End -->") (parent navigator) + (callback (lambda (b e) (navigate-to-end))))) + (define nav:down + (new button% (label "Next term") (parent navigator) + (callback (lambda (b e) (navigate-down))))) + + (define/private (trim-navigator) + (if (> (length (cursor->list terms)) 1) + (send navigator change-children + (lambda _ + (list nav:up + nav:start + nav:previous + nav:next + nav:end + nav:down))) + (send navigator change-children + (lambda _ + (list nav:start + nav:previous + nav:next + nav:end))))) + + (define/public (show-macro-hiding-prefs show?) + (send area change-children + (lambda (children) + (if show? + (append (remq control-pane children) (list control-pane)) + (remq control-pane children))))) + + (define/private (show-extra-navigation show?) + (send supernavigator change-children + (lambda (children) + (if show? + (list navigator extra-navigator) + (list navigator))))) + + ;; Navigation + + (define/public-final (at-start?) + (send (focused-term) at-start?)) + (define/public-final (at-end?) + (send (focused-term) at-end?)) + + (define/public-final (navigate-to-start) + (send (focused-term) navigate-to-start) + (update/save-position)) + (define/public-final (navigate-to-end) + (send (focused-term) navigate-to-end) + (update/save-position)) + (define/public-final (navigate-previous) + (send (focused-term) navigate-previous) + (update/save-position)) + (define/public-final (navigate-next) + (send (focused-term) navigate-next) + (update/save-position)) + + (define/public-final (navigate-up) + (when (focused-term) + (send (focused-term) on-lose-focus)) + (cursor:move-prev terms) + (refresh/move)) + (define/public-final (navigate-down) + (when (focused-term) + (send (focused-term) on-lose-focus)) + (cursor:move-next terms) + (refresh/move)) + + ;; Update + + ;; update/save-position : -> void + (define/private (update/save-position) + (update/preserve-lines-view)) + + ;; update/preserve-lines-view : -> void + (define/public (update/preserve-lines-view) + (define text (send sbview get-text)) + (define start-box (box 0)) + (define end-box (box 0)) + (send text get-visible-line-range start-box end-box) + (update) + (send text scroll-to-position + (send text line-start-position (unbox start-box)) + #f + (send text line-start-position (unbox end-box)) + 'start)) + + ;; update/preserve-view : -> void + (define/public (update/preserve-view) + (define text (send sbview get-text)) + (define start-box (box 0)) + (define end-box (box 0)) + (send text get-visible-position-range start-box end-box) + (update) + (send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start)) + + ;; update : -> void + ;; Updates the terms in the syntax browser to the current step + (define/private (update) + (define text (send sbview get-text)) + (define position-of-interest 0) + (define multiple-terms? (> (length (cursor->list terms)) 1)) + (send text begin-edit-sequence) + (send sbview erase-all) - (define warnings-area (new stepper-warnings% (parent area))) - - (define sbview (new stepper-syntax-widget% - (parent area) - (macro-stepper this))) - (define sbc (send sbview get-controller)) - (define control-pane - (new vertical-panel% (parent area) (stretchable-height #f))) - (define macro-hiding-prefs - (new macro-hiding-prefs-widget% - (parent control-pane) - (stepper this) - (config config))) + (update:show-prefix) + (when multiple-terms? (send sbview add-separator)) + (set! position-of-interest (send text last-position)) + (update:show-current-step) + (when multiple-terms? (send sbview add-separator)) + (update:show-suffix) + (send text end-edit-sequence) + (send text scroll-to-position + position-of-interest + #f + (send text last-position) + 'start) + (enable/disable-buttons)) - (send config listen-show-syntax-properties? - (lambda (show?) (send sbview show-props show?))) - (send config listen-show-hiding-panel? - (lambda (show?) (show-macro-hiding-prefs show?))) - (send sbc listen-selected-syntax - (lambda (stx) (send macro-hiding-prefs set-syntax stx))) - (send config listen-highlight-foci? - (lambda (_) (update/preserve-view))) - (send config listen-highlight-frontier? - (lambda (_) (update/preserve-view))) - (send config listen-show-rename-steps? - (lambda (_) (refresh/re-reduce))) - (send config listen-one-by-one? - (lambda (_) (refresh/re-reduce))) - (send config listen-force-letrec-transformation? - (lambda (_) (refresh/resynth))) - (send config listen-extra-navigation? - (lambda (show?) (show-extra-navigation show?))) + ;; update:show-prefix : -> void + (define/private (update:show-prefix) + ;; Show the final terms from the cached synth'd derivs + (for-each (lambda (trec) (send trec display-final-term)) + (cursor:prefix->list terms))) - (define nav:up - (new button% (label "Previous term") (parent navigator) - (callback (lambda (b e) (navigate-up))))) - (define nav:start - (new button% (label "<-- Start") (parent navigator) - (callback (lambda (b e) (navigate-to-start))))) - (define nav:previous - (new button% (label "<- Step") (parent navigator) - (callback (lambda (b e) (navigate-previous))))) - (define nav:next - (new button% (label "Step ->") (parent navigator) - (callback (lambda (b e) (navigate-next))))) - (define nav:end - (new button% (label "End -->") (parent navigator) - (callback (lambda (b e) (navigate-to-end))))) - (define nav:down - (new button% (label "Next term") (parent navigator) - (callback (lambda (b e) (navigate-down))))) + ;; update:show-current-step : -> void + (define/private (update:show-current-step) + (when (focused-term) + (send (focused-term) display-step))) - (define/private (trim-navigator) - (if (> (length (cursor->list terms)) 1) - (send navigator change-children - (lambda _ - (list nav:up - nav:start - nav:previous - nav:next - nav:end - nav:down))) - (send navigator change-children - (lambda _ - (list nav:start - nav:previous - nav:next - nav:end))))) + ;; update:show-suffix : -> void + (define/private (update:show-suffix) + (let ([suffix0 (cursor:suffix->list terms)]) + (when (pair? suffix0) + (for-each (lambda (trec) + (send trec display-initial-term)) + (cdr suffix0))))) - (define/public (show-macro-hiding-prefs show?) - (send area change-children - (lambda (children) - (if show? - (append (remq control-pane children) (list control-pane)) - (remq control-pane children))))) + ;; enable/disable-buttons : -> void + (define/private (enable/disable-buttons) + (define term (focused-term)) + (send nav:start enable (and term (send term has-prev?))) + (send nav:previous enable (and term (send term has-prev?))) + (send nav:next enable (and term (send term has-next?))) + (send nav:end enable (and term (send term has-next?))) + (send nav:up enable (cursor:has-prev? terms)) + (send nav:down enable (cursor:has-next? terms))) - (define/private (show-extra-navigation show?) - (send supernavigator change-children - (lambda (children) - (if show? - (list navigator extra-navigator) - (list navigator))))) + ;; -- - ;; Navigation + ;; refresh/resynth : -> void + ;; Macro hiding policy has changed; invalidate cached parts of trec + (define/public (refresh/resynth) + (for-each (lambda (trec) (send trec invalidate-synth!)) + (cursor->list terms)) + (refresh)) - (define/public-final (at-start?) - (send (focused-term) at-start?)) - (define/public-final (at-end?) - (send (focused-term) at-end?)) + ;; refresh/re-reduce : -> void + ;; Reduction config has changed; invalidate cached parts of trec + (define/private (refresh/re-reduce) + (for-each (lambda (trec) (send trec invalidate-steps!)) + (cursor->list terms)) + (refresh)) - (define/public-final (navigate-to-start) - (send (focused-term) navigate-to-start) - (update/save-position)) - (define/public-final (navigate-to-end) - (send (focused-term) navigate-to-end) - (update/save-position)) - (define/public-final (navigate-previous) - (send (focused-term) navigate-previous) - (update/save-position)) - (define/public-final (navigate-next) - (send (focused-term) navigate-next) - (update/save-position)) + ;; refresh/move : -> void + ;; Moving between terms; clear the saved position + (define/private (refresh/move) + (refresh)) - (define/public-final (navigate-up) - (when (focused-term) - (send (focused-term) on-lose-focus)) - (cursor:move-prev terms) - (refresh/move)) - (define/public-final (navigate-down) - (when (focused-term) - (send (focused-term) on-lose-focus)) - (cursor:move-next terms) - (refresh/move)) + ;; refresh : -> void + (define/public (refresh) + (send warnings-area clear) + (when (focused-term) + (send (focused-term) on-get-focus)) + (update)) - ;; Update + ;; delayed-recache-errors : (list-of (cons exn string)) + (define delayed-recache-errors null) - ;; update/save-position : -> void - (define/private (update/save-position) - (update/preserve-lines-view)) + ;; handle-recache-error : exception string -> void + (define/private (handle-recache-error exn part) + (if (send config get-debug-catch-errors?) + (begin + (set! delayed-recache-errors + (cons (cons exn part) delayed-recache-errors)) + (queue-callback + (lambda () + (when (pair? delayed-recache-errors) + (message-box + "Error" + (string-append + "Internal errors in macro stepper:\n" + (if (memq 'macro-hiding (map cdr delayed-recache-errors)) + (string-append + "Macro hiding failed on one or more terms. " + "The macro stepper is showing the terms " + "with macro hiding disabled.\n") + "") + (if (memq 'reductions (map cdr delayed-recache-errors)) + (string-append + "The macro stepper failed to compute the reduction sequence " + "for one or more terms.\n") + ""))) + (set! delayed-recache-errors null))))) + (raise exn))) - ;; update/preserve-lines-view : -> void - (define/public (update/preserve-lines-view) - (define text (send sbview get-text)) - (define start-box (box 0)) - (define end-box (box 0)) - (send text get-visible-line-range start-box end-box) - (update) - (send text scroll-to-position - (send text line-start-position (unbox start-box)) - #f - (send text line-start-position (unbox end-box)) - 'start)) - - ;; update/preserve-view : -> void - (define/public (update/preserve-view) - (define text (send sbview get-text)) - (define start-box (box 0)) - (define end-box (box 0)) - (send text get-visible-position-range start-box end-box) - (update) - (send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start)) + (define/private (foci x) (if (list? x) x (list x))) - ;; update : -> void - ;; Updates the terms in the syntax browser to the current step - (define/private (update) - (define text (send sbview get-text)) - (define position-of-interest 0) - (define multiple-terms? (> (length (cursor->list terms)) 1)) - (send text begin-edit-sequence) - (send sbview erase-all) - - (update:show-prefix) - (when multiple-terms? (send sbview add-separator)) - (set! position-of-interest (send text last-position)) - (update:show-current-step) - (when multiple-terms? (send sbview add-separator)) - (update:show-suffix) - (send text end-edit-sequence) - (send text scroll-to-position - position-of-interest - #f - (send text last-position) - 'start) - (enable/disable-buttons)) + ;; Hiding policy + + (define/public (get-show-macro?) + (send macro-hiding-prefs get-policy)) - ;; update:show-prefix : -> void - (define/private (update:show-prefix) - ;; Show the final terms from the cached synth'd derivs - (for-each (lambda (trec) (send trec display-final-term)) - (cursor:prefix->list terms))) + ;; Derivation pre-processing - ;; update:show-current-step : -> void - (define/private (update:show-current-step) - (when (focused-term) - (send (focused-term) display-step))) + (define/public (get-preprocess-deriv) (lambda (d) d)) - ;; update:show-suffix : -> void - (define/private (update:show-suffix) - (let ([suffix0 (cursor:suffix->list terms)]) - (when (pair? suffix0) - (for-each (lambda (trec) - (send trec display-initial-term)) - (cdr suffix0))))) + ;; Initialization - ;; enable/disable-buttons : -> void - (define/private (enable/disable-buttons) - (define term (focused-term)) - (send nav:start enable (and term (send term has-prev?))) - (send nav:previous enable (and term (send term has-prev?))) - (send nav:next enable (and term (send term has-next?))) - (send nav:end enable (and term (send term has-next?))) - (send nav:up enable (cursor:has-prev? terms)) - (send nav:down enable (cursor:has-next? terms))) + (super-new) + (send sbview show-props (send config get-show-syntax-properties?)) + (show-macro-hiding-prefs (send config get-show-hiding-panel?)) + (show-extra-navigation (send config get-extra-navigation?)) + (refresh/move) + )) - ;; -- +(define (macro-stepper-widget/process-mixin %) + (class % + (super-new) + (define/override (get-preprocess-deriv) + (lambda (d) (get-original-part d))) - ;; refresh/resynth : -> void - ;; Macro hiding policy has changed; invalidate cached parts of trec - (define/public (refresh/resynth) - (for-each (lambda (trec) (send trec invalidate-synth!)) - (cursor->list terms)) - (refresh)) + ;; get-original-part : Deriv -> Deriv/#f + ;; Strip off mzscheme's #%top-interaction + ;; Careful: the #%top-interaction node may be inside of a lift-deriv + (define/private (get-original-part deriv) + (let ([deriv* (adjust-deriv/lift deriv)]) + deriv*)) + + ;; adjust-deriv/lift : Derivation -> (list-of Derivation) + (define/private (adjust-deriv/lift deriv) + (match deriv + [(Wrap lift-deriv (e1 e2 first lifted-stx second)) + (let ([first (adjust-deriv/top first)]) + (and first + (let ([e1 (wderiv-e1 first)]) + (make-lift-deriv e1 e2 first lifted-stx second))))] + [else (adjust-deriv/top deriv)])) - ;; refresh/re-reduce : -> void - ;; Reduction config has changed; invalidate cached parts of trec - (define/private (refresh/re-reduce) - (for-each (lambda (trec) (send trec invalidate-steps!)) - (cursor->list terms)) - (refresh)) + ;; adjust-deriv/top : Derivation -> Derivation + (define/private (adjust-deriv/top deriv) + (if (syntax-source (wderiv-e1 deriv)) + deriv + ;; It's not original... + ;; Strip out mzscheme's top-interactions + ;; Keep anything that is a non-mzscheme top-interaction + ;; Drop everything else (not original program) + (match deriv + [(Wrap mrule (e1 e2 tx next)) + (match tx + [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq)) + (cond [(ormap (lambda (x) (top-interaction-kw? x)) + rs) + ;; Just mzscheme's top-interaction; strip it out + (adjust-deriv/top next)] + [(equal? (map syntax-e rs) '(#%top-interaction)) + ;; A *different* top interaction; keep it + deriv] + [else + ;; Not original and not tagged with top-interaction + #f])])] + [else #f]))) - ;; refresh/move : -> void - ;; Moving between terms; clear the saved position - (define/private (refresh/move) - (refresh)) + (define/public (top-interaction-kw? x) + (free-identifier=? x #'#%top-interaction)) - ;; refresh : -> void - (define/public (refresh) - (send warnings-area clear) - (when (focused-term) - (send (focused-term) on-get-focus)) - (update)) - - ;; delayed-recache-errors : (list-of (cons exn string)) - (define delayed-recache-errors null) - - ;; handle-recache-error : exception string -> void - (define/private (handle-recache-error exn part) - (if (send config get-debug-catch-errors?) - (begin - (set! delayed-recache-errors - (cons (cons exn part) delayed-recache-errors)) - (queue-callback - (lambda () - (when (pair? delayed-recache-errors) - (message-box - "Error" - (string-append - "Internal errors in macro stepper:\n" - (if (memq 'macro-hiding (map cdr delayed-recache-errors)) - (string-append - "Macro hiding failed on one or more terms. " - "The macro stepper is showing the terms " - "with macro hiding disabled.\n") - "") - (if (memq 'reductions (map cdr delayed-recache-errors)) - (string-append - "The macro stepper failed to compute the reduction sequence " - "for one or more terms.\n") - ""))) - (set! delayed-recache-errors null))))) - (raise exn))) - - (define/private (foci x) (if (list? x) x (list x))) - - ;; Hiding policy - - (define/public (get-show-macro?) - (send macro-hiding-prefs get-policy)) - - ;; Derivation pre-processing - - (define/public (get-preprocess-deriv) (lambda (d) d)) - - ;; Initialization - - (super-new) - (send sbview show-props (send config get-show-syntax-properties?)) - (show-macro-hiding-prefs (send config get-show-hiding-panel?)) - (show-extra-navigation (send config get-extra-navigation?)) - (refresh/move) - )) - - (define (macro-stepper-widget/process-mixin %) - (class % - (super-new) - (define/override (get-preprocess-deriv) - (lambda (d) (get-original-part d))) - - ;; get-original-part : Deriv -> Deriv/#f - ;; Strip off mzscheme's #%top-interaction - ;; Careful: the #%top-interaction node may be inside of a lift-deriv - (define/private (get-original-part deriv) - (let ([deriv* (adjust-deriv/lift deriv)]) - deriv*)) - - ;; adjust-deriv/lift : Derivation -> (list-of Derivation) - (define/private (adjust-deriv/lift deriv) - (match deriv - [(Wrap lift-deriv (e1 e2 first lifted-stx second)) - (let ([first (adjust-deriv/top first)]) - (and first - (let ([e1 (wderiv-e1 first)]) - (make-lift-deriv e1 e2 first lifted-stx second))))] - [else (adjust-deriv/top deriv)])) - - ;; adjust-deriv/top : Derivation -> Derivation - (define/private (adjust-deriv/top deriv) - (if (syntax-source (wderiv-e1 deriv)) - deriv - ;; It's not original... - ;; Strip out mzscheme's top-interactions - ;; Keep anything that is a non-mzscheme top-interaction - ;; Drop everything else (not original program) - (match deriv - [(Wrap mrule (e1 e2 tx next)) - (match tx - [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq)) - (cond [(ormap (lambda (x) (top-interaction-kw? x)) - rs) - ;; Just mzscheme's top-interaction; strip it out - (adjust-deriv/top next)] - [(equal? (map syntax-e rs) '(#%top-interaction)) - ;; A *different* top interaction; keep it - deriv] - [else - ;; Not original and not tagged with top-interaction - #f])])] - [else #f]))) - - (define/public (top-interaction-kw? x) - (module-identifier=? x #'#%top-interaction)) - - )) - ) + )) diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index 1f76f96..9c54325 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -1,542 +1,540 @@ -(module term-record mzscheme - (require (lib "class.ss") - (lib "unit.ss") - (lib "list.ss") - (lib "plt-match.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - (lib "boundmap.ss" "syntax") - "interfaces.ss" - "prefs.ss" - "extensions.ss" - "warning.ss" - "hiding-panel.ss" - (prefix s: "../syntax-browser/widget.ss") - (prefix s: "../syntax-browser/params.ss") - "../model/deriv.ss" - "../model/deriv-util.ss" - "../model/deriv-find.ss" - "../model/deriv-parser.ss" - "../model/trace.ss" - "../model/reductions.ss" - "../model/hide.ss" - "../model/steps.ss" - "debug-format.ss" - "cursor.ss" - "util.ss") +#lang scheme/base +(require scheme/class + scheme/unit + scheme/list + scheme/match + scheme/gui + framework/framework + syntax/boundmap + "interfaces.ss" + "prefs.ss" + "extensions.ss" + "warning.ss" + "hiding-panel.ss" + (prefix-in s: "../syntax-browser/widget.ss") + (prefix-in s: "../syntax-browser/params.ss") + "../model/deriv.ss" + "../model/deriv-util.ss" + "../model/deriv-find.ss" + "../model/deriv-parser.ss" + "../model/trace.ss" + "../model/reductions.ss" + "../model/hide.ss" + "../model/steps.ss" + "debug-format.ss" + "cursor.ss" + "../util/notify.ss") - (provide term-record%) +(provide term-record%) - ;; Struct for one-by-one stepping +;; Struct for one-by-one stepping - (define-struct (prestep protostep) (foci1 e1)) - (define-struct (poststep protostep) (foci2 e2)) +(define-struct (prestep protostep) (foci1 e1)) +(define-struct (poststep protostep) (foci2 e2)) - (define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s))) - (define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s))) +(define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s))) +(define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s))) - ;; TermRecords +;; TermRecords - (define term-record% - (class object% - (init-field stepper) - (init-field [events #f]) +(define term-record% + (class object% + (init-field stepper) + (init-field [events #f]) - (define config (send stepper get-config)) - (define sbview (send stepper get-view)) + (define config (send stepper get-config)) + (define sbview (send stepper get-view)) - (init-field [raw-deriv #f]) - (define raw-deriv-oops #f) + (init-field [raw-deriv #f]) + (define raw-deriv-oops #f) - (define deriv #f) - (define deriv-hidden? #f) - (define binders #f) + (define deriv #f) + (define deriv-hidden? #f) + (define binders #f) - (define synth-deriv #f) - (define synth-warnings null) - (define synth-estx #f) - (define synth-oops #f) + (define synth-deriv #f) + (define synth-warnings null) + (define synth-estx #f) + (define synth-oops #f) - (define raw-steps #f) - (define raw-steps-estx #f) - (define definites #f) - (define error #f) - (define raw-steps-oops #f) + (define raw-steps #f) + (define raw-steps-estx #f) + (define definites #f) + (define error #f) + (define raw-steps-oops #f) - (define steps #f) + (define steps #f) - (define steps-position #f) + (define steps-position #f) - (super-new) + (super-new) - (define-syntax define-guarded-getters - (syntax-rules () - [(define-guarded-getters guard (method expr) ...) - (begin (define/public (method) guard expr) ...)])) + (define-syntax define-guarded-getters + (syntax-rules () + [(define-guarded-getters guard (method expr) ...) + (begin (define/public (method) guard expr) ...)])) - (define-guarded-getters (recache-deriv!) - [get-deriv deriv] - [get-deriv-hidden? deriv-hidden?] - [get-binders binders]) - (define-guarded-getters (recache-synth!) - [get-synth-deriv synth-deriv] - [get-synth-warnings synth-warnings] - [get-synth-estx synth-estx] - [get-synth-oops synth-oops]) - (define-guarded-getters (recache-raw-steps!) - [get-definites definites] - [get-error error] - [get-raw-steps-oops raw-steps-oops]) - (define-guarded-getters (recache-steps!) - [get-steps steps]) + (define-guarded-getters (recache-deriv!) + [get-deriv deriv] + [get-deriv-hidden? deriv-hidden?] + [get-binders binders]) + (define-guarded-getters (recache-synth!) + [get-synth-deriv synth-deriv] + [get-synth-warnings synth-warnings] + [get-synth-estx synth-estx] + [get-synth-oops synth-oops]) + (define-guarded-getters (recache-raw-steps!) + [get-definites definites] + [get-error error] + [get-raw-steps-oops raw-steps-oops]) + (define-guarded-getters (recache-steps!) + [get-steps steps]) - ;; invalidate-steps! : -> void - ;; Invalidates cached parts that depend on reductions config - (define/public (invalidate-steps!) - (set! steps #f)) + ;; invalidate-steps! : -> void + ;; Invalidates cached parts that depend on reductions config + (define/public (invalidate-steps!) + (set! steps #f)) - ;; invalidate-raw-steps! : -> void - (define/public (invalidate-raw-steps!) - (invalidate-steps!) - (set! raw-steps #f) - (set! raw-steps-estx #f) - (set! definites #f) - (set! error #f) - (set! raw-steps-oops #f)) + ;; invalidate-raw-steps! : -> void + (define/public (invalidate-raw-steps!) + (invalidate-steps!) + (set! raw-steps #f) + (set! raw-steps-estx #f) + (set! definites #f) + (set! error #f) + (set! raw-steps-oops #f)) - ;; invalidate-synth! : -> void - ;; Invalidates cached parts that depend on macro-hiding policy - (define/public (invalidate-synth!) - (invalidate-raw-steps!) - (set! synth-deriv #f) - (set! synth-warnings null) - (set! synth-oops #f) - (set! synth-estx #f)) + ;; invalidate-synth! : -> void + ;; Invalidates cached parts that depend on macro-hiding policy + (define/public (invalidate-synth!) + (invalidate-raw-steps!) + (set! synth-deriv #f) + (set! synth-warnings null) + (set! synth-oops #f) + (set! synth-estx #f)) - ;; invalidate-deriv! : -> void - (define/public (invalidate-deriv!) - (invalidate-synth!) - (set! deriv #f) - (set! deriv-hidden? #f) - (set! binders #f)) + ;; invalidate-deriv! : -> void + (define/public (invalidate-deriv!) + (invalidate-synth!) + (set! deriv #f) + (set! deriv-hidden? #f) + (set! binders #f)) - ;; recache! : -> void - (define/public (recache!) - (recache-steps!)) + ;; recache! : -> void + (define/public (recache!) + (recache-steps!)) - ;; recache-raw-deriv! : -> void - (define/private (recache-raw-deriv!) - (unless (or raw-deriv raw-deriv-oops) - (with-handlers ([(lambda (e) #t) - (lambda (e) - (set! raw-deriv-oops e))]) - (set! raw-deriv - (parse-derivation - (events->token-generator events)))))) + ;; recache-raw-deriv! : -> void + (define/private (recache-raw-deriv!) + (unless (or raw-deriv raw-deriv-oops) + (with-handlers ([(lambda (e) #t) + (lambda (e) + (set! raw-deriv-oops e))]) + (set! raw-deriv + (parse-derivation + (events->token-generator events)))))) - ;; recache-deriv! : -> void - (define/private (recache-deriv!) - (unless (or deriv deriv-hidden?) - (recache-raw-deriv!) - (when raw-deriv - (let ([process (send stepper get-preprocess-deriv)]) - (let ([d (process raw-deriv)]) - (when (not d) - (set! deriv-hidden? #t)) - (when d - (let ([alpha-table (make-module-identifier-mapping)]) - (for-each (lambda (id) - (module-identifier-mapping-put! alpha-table id id)) - (extract-all-fresh-names d)) - (set! deriv d) - (set! binders alpha-table)))))))) + ;; recache-deriv! : -> void + (define/private (recache-deriv!) + (unless (or deriv deriv-hidden?) + (recache-raw-deriv!) + (when raw-deriv + (let ([process (send stepper get-preprocess-deriv)]) + (let ([d (process raw-deriv)]) + (when (not d) + (set! deriv-hidden? #t)) + (when d + (let ([alpha-table (make-module-identifier-mapping)]) + (for-each (lambda (id) + (module-identifier-mapping-put! alpha-table id id)) + (extract-all-fresh-names d)) + (set! deriv d) + (set! binders alpha-table)))))))) - ;; recache-synth! : -> void - (define/private (recache-synth!) - (unless (or synth-deriv synth-oops) - (recache-deriv!) - (when deriv - (set! synth-warnings null) - (let ([show-macro? (send stepper get-show-macro?)] - [force-letrec? (send config get-force-letrec-transformation?)]) - (with-handlers ([(lambda (e) #t) - (lambda (e) - (set! synth-oops e))]) - (let () - (define-values (synth-deriv* estx*) - (if show-macro? - (parameterize ((current-hiding-warning-handler - (lambda (tag args) - (set! synth-warnings - (cons (cons tag args) - synth-warnings)))) - (force-letrec-transformation - force-letrec?)) - (hide/policy deriv show-macro?)) - (values deriv (wderiv-e2 deriv)))) - (set! synth-deriv synth-deriv*) - (set! synth-estx estx*))))))) - - ;; recache-raw-steps! : -> void - (define/private (recache-raw-steps!) - (unless (or raw-steps raw-steps-oops) - (recache-synth!) - (when synth-deriv + ;; recache-synth! : -> void + (define/private (recache-synth!) + (unless (or synth-deriv synth-oops) + (recache-deriv!) + (when deriv + (set! synth-warnings null) + (let ([show-macro? (send stepper get-show-macro?)] + [force-letrec? (send config get-force-letrec-transformation?)]) (with-handlers ([(lambda (e) #t) (lambda (e) - (set! raw-steps-oops e))]) - (let-values ([(raw-steps* definites* estx* error*) - (reductions+ synth-deriv)]) - (set! raw-steps raw-steps*) - (set! raw-steps-estx estx*) - (set! error error*) - (set! definites definites*)))))) + (set! synth-oops e))]) + (let () + (define-values (synth-deriv* estx*) + (if show-macro? + (parameterize ((current-hiding-warning-handler + (lambda (tag args) + (set! synth-warnings + (cons (cons tag args) + synth-warnings)))) + (force-letrec-transformation + force-letrec?)) + (hide/policy deriv show-macro?)) + (values deriv (wderiv-e2 deriv)))) + (set! synth-deriv synth-deriv*) + (set! synth-estx estx*))))))) - ;; recache-steps! : -> void - (define/private (recache-steps!) - (unless (or steps) - (recache-raw-steps!) - (when raw-steps - (set! steps - (and raw-steps - (let* ([filtered-steps - (if (send config get-show-rename-steps?) - raw-steps - (filter (lambda (x) (not (rename-step? x))) - raw-steps))] - [processed-steps - (if (send config get-one-by-one?) - (reduce:one-by-one filtered-steps) - filtered-steps)]) - (cursor:new processed-steps)))) - (restore-position)))) - - ;; reduce:one-by-one : (list-of step) -> (list-of step) - (define/private (reduce:one-by-one rs) - (let loop ([rs rs]) - (match rs - [(cons (struct step (d l t c df fr redex contractum e1 e2)) rs) - (list* (make-prestep d l "Find redex" c df fr redex e1) - (make-poststep d l t c df fr contractum e2) - (loop rs))] - [(cons (struct misstep (d l t c df fr redex e1 exn)) rs) - (list* (make-prestep d l "Find redex" c df fr redex e1) - (make-misstep d l t c df fr redex e1 exn) - (loop rs))] - ['() - null]))) - - ;; Navigation - - (define/public-final (has-prev?) - (and (get-steps) (not (cursor:at-start? (get-steps))))) - (define/public-final (has-next?) - (and (get-steps) (not (cursor:at-end? (get-steps))))) - - (define/public-final (navigate-to-start) - (cursor:move-to-start (get-steps)) - (save-position)) - (define/public-final (navigate-to-end) - (cursor:move-to-end (get-steps)) - (save-position)) - (define/public-final (navigate-previous) - (cursor:move-prev (get-steps)) - (save-position)) - (define/public-final (navigate-next) - (cursor:move-next (get-steps)) - (save-position)) - - ;; save-position : -> void - (define/private (save-position) - (when (cursor? steps) - (let ([step (cursor:next steps)]) - (cond [(not step) - ;; At end; go to the end when restored - (set! steps-position +inf.0)] - [(protostep? step) - (set! steps-position - (extract-protostep-seq step))])))) - - ;; restore-position : number -> void - (define/private (restore-position) - (define (seek) - (let ([step (cursor:next steps)]) - (cond [(not step) - ;; At end; stop - (void)] - [(protostep? step) - (let ([step-pos (extract-protostep-seq step)]) - (cond [(not step-pos) - (cursor:move-next steps) - (seek)] - [(< step-pos steps-position) - (cursor:move-next steps) - (seek)] - [else (void)]))]))) - (when steps-position - (seek))) - - ;; extract-protostep-seq : step -> number/#f - (define/private (extract-protostep-seq step) - (match (protostep-deriv step) - [(Wrap mrule (_ _ (Wrap transformation (_ _ _ _ _ _ _ _ seq)) _)) - seq] - [else #f])) - - ;; Warnings display - - ;; on-get-focus : -> void - (define/public (on-get-focus) + ;; recache-raw-steps! : -> void + (define/private (recache-raw-steps!) + (unless (or raw-steps raw-steps-oops) (recache-synth!) - (display-warnings)) + (when synth-deriv + (with-handlers ([(lambda (e) #t) + (lambda (e) + (set! raw-steps-oops e))]) + (let-values ([(raw-steps* definites* estx* error*) + (reductions+ synth-deriv)]) + (set! raw-steps raw-steps*) + (set! raw-steps-estx estx*) + (set! error error*) + (set! definites definites*)))))) - ;; on-lose-focus : -> void - (define/public (on-lose-focus) - (when steps (cursor:move-to-start steps)) - (set! steps-position #f)) + ;; recache-steps! : -> void + (define/private (recache-steps!) + (unless (or steps) + (recache-raw-steps!) + (when raw-steps + (set! steps + (and raw-steps + (let* ([filtered-steps + (if (send config get-show-rename-steps?) + raw-steps + (filter (lambda (x) (not (rename-step? x))) + raw-steps))] + [processed-steps + (if (send config get-one-by-one?) + (reduce:one-by-one filtered-steps) + filtered-steps)]) + (cursor:new processed-steps)))) + (restore-position)))) - ;; display-warnings : -> void - (define/private (display-warnings) - (let ([warnings-area (send stepper get-warnings-area)]) - (unless (send config get-suppress-warnings?) - (for-each (lambda (tag+args) - (let ([tag (car tag+args)] - [args (cdr tag+args)]) - (send warnings-area add-warning tag args))) - synth-warnings)))) + ;; reduce:one-by-one : (list-of step) -> (list-of step) + (define/private (reduce:one-by-one rs) + (let loop ([rs rs]) + (match rs + [(cons (struct step (d l t c df fr redex contractum e1 e2)) rs) + (list* (make-prestep d l "Find redex" c df fr redex e1) + (make-poststep d l t c df fr contractum e2) + (loop rs))] + [(cons (struct misstep (d l t c df fr redex e1 exn)) rs) + (list* (make-prestep d l "Find redex" c df fr redex e1) + (make-misstep d l t c df fr redex e1 exn) + (loop rs))] + ['() + null]))) - ;; Rendering + ;; Navigation - ;; display-initial-term : -> void - (define/public (display-initial-term) - (add-syntax (wderiv-e1 deriv) #f null)) + (define/public-final (has-prev?) + (and (get-steps) (not (cursor:at-start? (get-steps))))) + (define/public-final (has-next?) + (and (get-steps) (not (cursor:at-end? (get-steps))))) - ;; display-final-term : -> void - (define/public (display-final-term) - (recache-synth!) - (cond [(syntax? synth-estx) - (add-syntax synth-estx binders definites)] - [(exn? error) - (add-error error)] - [raw-steps-oops - (add-internal-error "steps" raw-steps-oops #f)] - [synth-oops - (add-internal-error "hiding" synth-oops #f)])) + (define/public-final (navigate-to-start) + (cursor:move-to-start (get-steps)) + (save-position)) + (define/public-final (navigate-to-end) + (cursor:move-to-end (get-steps)) + (save-position)) + (define/public-final (navigate-previous) + (cursor:move-prev (get-steps)) + (save-position)) + (define/public-final (navigate-next) + (cursor:move-next (get-steps)) + (save-position)) - ;; display-step : -> void - (define/public (display-step) - (recache-steps!) - (cond [steps - (let ([step (cursor:next steps)]) - (if step - (add-step step binders) - (add-final raw-steps-estx error binders definites)))] - [raw-steps-oops - (add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))] - [synth-oops - (add-internal-error "hiding" synth-oops (wderiv-e1 deriv))] - [raw-deriv-oops - (add-internal-error "derivation" raw-deriv-oops #f)] - [else - (add-internal-error "derivation" #f)])) + ;; save-position : -> void + (define/private (save-position) + (when (cursor? steps) + (let ([step (cursor:next steps)]) + (cond [(not step) + ;; At end; go to the end when restored + (set! steps-position +inf.0)] + [(protostep? step) + (set! steps-position + (extract-protostep-seq step))])))) - (define/public (add-internal-error part exn stx) - (send sbview add-text - (if part - (format "Macro stepper error (~a)" part) - "Macro stepper error")) - (when (exn? exn) - (send sbview add-text " ") - (send sbview add-clickback "[details]" - (lambda _ (show-internal-error-details exn)))) - (send sbview add-text ". ") - (when stx (send sbview add-text "Original syntax:")) - (send sbview add-text "\n") - (when stx (send sbview add-syntax stx))) + ;; restore-position : number -> void + (define/private (restore-position) + (define (seek) + (let ([step (cursor:next steps)]) + (cond [(not step) + ;; At end; stop + (void)] + [(protostep? step) + (let ([step-pos (extract-protostep-seq step)]) + (cond [(not step-pos) + (cursor:move-next steps) + (seek)] + [(< step-pos steps-position) + (cursor:move-next steps) + (seek)] + [else (void)]))]))) + (when steps-position + (seek))) - (define/private (show-internal-error-details exn) - (case (message-box/custom "Macro stepper internal error" - (format "Internal error:\n~a" (exn-message exn)) - "Show error" - "Dump debugging file" - "Cancel") - ((1) (queue-callback - (lambda () - (raise exn)))) - ((2) (queue-callback - (lambda () - (let ([file (put-file)]) - (when file - (write-debug-file file exn events)))))) - ((3 #f) (void)))) + ;; extract-protostep-seq : step -> number/#f + (define/private (extract-protostep-seq step) + (match (protostep-deriv step) + [(Wrap mrule (_ _ (Wrap transformation (_ _ _ _ _ _ _ _ seq)) _)) + seq] + [else #f])) - (define/public (add-error exn) - (send sbview add-error-text (exn-message exn)) - (send sbview add-text "\n")) + ;; Warnings display - (define/public (add-step step binders) - (cond [(step? step) - (show-step step binders)] - [(mono? step) - (show-mono step binders)] - [(misstep? step) - (show-misstep step binders)] - [(prestep? step) - (show-prestep step binders)] - [(poststep? step) - (show-poststep step binders)])) + ;; on-get-focus : -> void + (define/public (on-get-focus) + (recache-synth!) + (display-warnings)) - (define/public (add-syntax stx binders definites) + ;; on-lose-focus : -> void + (define/public (on-lose-focus) + (when steps (cursor:move-to-start steps)) + (set! steps-position #f)) + + ;; display-warnings : -> void + (define/private (display-warnings) + (let ([warnings-area (send stepper get-warnings-area)]) + (unless (send config get-suppress-warnings?) + (for-each (lambda (tag+args) + (let ([tag (car tag+args)] + [args (cdr tag+args)]) + (send warnings-area add-warning tag args))) + synth-warnings)))) + + ;; Rendering + + ;; display-initial-term : -> void + (define/public (display-initial-term) + (add-syntax (wderiv-e1 deriv) #f null)) + + ;; display-final-term : -> void + (define/public (display-final-term) + (recache-synth!) + (cond [(syntax? synth-estx) + (add-syntax synth-estx binders definites)] + [(exn? error) + (add-error error)] + [raw-steps-oops + (add-internal-error "steps" raw-steps-oops #f)] + [synth-oops + (add-internal-error "hiding" synth-oops #f)])) + + ;; display-step : -> void + (define/public (display-step) + (recache-steps!) + (cond [steps + (let ([step (cursor:next steps)]) + (if step + (add-step step binders) + (add-final raw-steps-estx error binders definites)))] + [raw-steps-oops + (add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))] + [synth-oops + (add-internal-error "hiding" synth-oops (wderiv-e1 deriv))] + [raw-deriv-oops + (add-internal-error "derivation" raw-deriv-oops #f)] + [else + (add-internal-error "derivation" #f)])) + + (define/public (add-internal-error part exn stx) + (send sbview add-text + (if part + (format "Macro stepper error (~a)" part) + "Macro stepper error")) + (when (exn? exn) + (send sbview add-text " ") + (send sbview add-clickback "[details]" + (lambda _ (show-internal-error-details exn)))) + (send sbview add-text ". ") + (when stx (send sbview add-text "Original syntax:")) + (send sbview add-text "\n") + (when stx (send sbview add-syntax stx))) + + (define/private (show-internal-error-details exn) + (case (message-box/custom "Macro stepper internal error" + (format "Internal error:\n~a" (exn-message exn)) + "Show error" + "Dump debugging file" + "Cancel") + ((1) (queue-callback + (lambda () + (raise exn)))) + ((2) (queue-callback + (lambda () + (let ([file (put-file)]) + (when file + (write-debug-file file exn events)))))) + ((3 #f) (void)))) + + (define/public (add-error exn) + (send sbview add-error-text (exn-message exn)) + (send sbview add-text "\n")) + + (define/public (add-step step binders) + (cond [(step? step) + (show-step step binders)] + [(mono? step) + (show-mono step binders)] + [(misstep? step) + (show-misstep step binders)] + [(prestep? step) + (show-prestep step binders)] + [(poststep? step) + (show-poststep step binders)])) + + (define/public (add-syntax stx binders definites) + (send sbview add-syntax stx + '#:alpha-table binders + '#:definites definites)) + + (define/private (add-final stx error binders definites) + (when stx + (send sbview add-text "Expansion finished\n") (send sbview add-syntax stx - #:alpha-table binders - #:definites definites)) + '#:alpha-table binders + '#:definites (or definites null))) + (when error + (add-error error))) - (define/private (add-final stx error binders definites) - (when stx - (send sbview add-text "Expansion finished\n") - (send sbview add-syntax stx - #:alpha-table binders - #:definites (or definites null))) - (when error - (add-error error))) - - ;; show-lctx : Step -> void - (define/private (show-lctx step binders) - (define lctx (protostep-lctx step)) - (when (pair? lctx) - (send sbview add-text "\n") - (for-each (lambda (bf) - (send sbview add-text - "while executing macro transformer in:\n") - (insert-syntax/redex (bigframe-term bf) - (bigframe-foci bf) - binders - (protostep-definites step) - (protostep-frontier step))) - (reverse lctx)))) - - ;; separator : Step -> void - (define/private (separator step) - (if (not (mono? step)) - (insert-step-separator (step-type->string (protostep-type step))) - (insert-as-separator (step-type->string (protostep-type step))))) - - ;; separator/small : Step -> void - (define/private (separator/small step) - (insert-step-separator/small - (step-type->string (protostep-type step)))) - - ;; show-step : Step -> void - (define/private (show-step step binders) - (insert-syntax/redex (step-term1 step) - (step-foci1 step) - binders - (protostep-definites step) - (protostep-frontier step)) - (separator step) - (insert-syntax/contractum (step-term2 step) - (step-foci2 step) - binders - (protostep-definites step) - (protostep-frontier step)) - (show-lctx step binders)) - - ;; show-mono : Step -> void - (define/private (show-mono step binders) - (separator step) - (insert-syntax/redex (mono-term1 step) - null - binders - (protostep-definites step) - (protostep-frontier step)) - (show-lctx step binders)) - - ;; show-prestep : Step -> void - (define/private (show-prestep step binders) - (separator/small step) - (insert-syntax/redex (prestep-term1 step) - (prestep-foci1 step) - binders - (protostep-definites step) - (protostep-frontier step)) - (show-lctx step binders)) - - ;; show-poststep : Step -> void - (define/private (show-poststep step binders) - (separator/small step) - (insert-syntax/contractum (poststep-term2 step) - (poststep-foci2 step) - binders - (protostep-definites step) - (protostep-frontier step)) - (show-lctx step binders)) - - ;; show-misstep : Step -> void - (define/private (show-misstep step binders) - (insert-syntax/redex (misstep-term1 step) - (misstep-foci1 step) - binders - (protostep-definites step) - (protostep-frontier step)) - (separator step) - (send sbview add-error-text (exn-message (misstep-exn step))) + ;; show-lctx : Step -> void + (define/private (show-lctx step binders) + (define lctx (protostep-lctx step)) + (when (pair? lctx) (send sbview add-text "\n") - (when (exn:fail:syntax? (misstep-exn step)) - (for-each (lambda (e) (send sbview add-syntax e - #:alpha-table binders - #:definites (protostep-definites step))) - (exn:fail:syntax-exprs (misstep-exn step)))) - (show-lctx step binders)) + (for-each (lambda (bf) + (send sbview add-text + "while executing macro transformer in:\n") + (insert-syntax/redex (bigframe-term bf) + (bigframe-foci bf) + binders + (protostep-definites step) + (protostep-frontier step))) + (reverse lctx)))) + + ;; separator : Step -> void + (define/private (separator step) + (if (not (mono? step)) + (insert-step-separator (step-type->string (protostep-type step))) + (insert-as-separator (step-type->string (protostep-type step))))) + + ;; separator/small : Step -> void + (define/private (separator/small step) + (insert-step-separator/small + (step-type->string (protostep-type step)))) + + ;; show-step : Step -> void + (define/private (show-step step binders) + (insert-syntax/redex (step-term1 step) + (step-foci1 step) + binders + (protostep-definites step) + (protostep-frontier step)) + (separator step) + (insert-syntax/contractum (step-term2 step) + (step-foci2 step) + binders + (protostep-definites step) + (protostep-frontier step)) + (show-lctx step binders)) + + ;; show-mono : Step -> void + (define/private (show-mono step binders) + (separator step) + (insert-syntax/redex (mono-term1 step) + null + binders + (protostep-definites step) + (protostep-frontier step)) + (show-lctx step binders)) + + ;; show-prestep : Step -> void + (define/private (show-prestep step binders) + (separator/small step) + (insert-syntax/redex (prestep-term1 step) + (prestep-foci1 step) + binders + (protostep-definites step) + (protostep-frontier step)) + (show-lctx step binders)) + + ;; show-poststep : Step -> void + (define/private (show-poststep step binders) + (separator/small step) + (insert-syntax/contractum (poststep-term2 step) + (poststep-foci2 step) + binders + (protostep-definites step) + (protostep-frontier step)) + (show-lctx step binders)) + + ;; show-misstep : Step -> void + (define/private (show-misstep step binders) + (insert-syntax/redex (misstep-term1 step) + (misstep-foci1 step) + binders + (protostep-definites step) + (protostep-frontier step)) + (separator step) + (send sbview add-error-text (exn-message (misstep-exn step))) + (send sbview add-text "\n") + (when (exn:fail:syntax? (misstep-exn step)) + (for-each (lambda (e) (send sbview add-syntax e + '#:alpha-table binders + '#:definites (protostep-definites step))) + (exn:fail:syntax-exprs (misstep-exn step)))) + (show-lctx step binders)) - ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void - (define/private (insert-syntax/color stx foci binders definites frontier hi-color) - (send sbview add-syntax stx - #:definites definites - #:alpha-table binders - #:hi-color hi-color - #:hi-stxs (if (send config get-highlight-foci?) foci null) - #:hi2-color "WhiteSmoke" - #:hi2-stxs (if (send config get-highlight-frontier?) frontier null))) + ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void + (define/private (insert-syntax/color stx foci binders definites frontier hi-color) + (send sbview add-syntax stx + '#:definites definites + '#:alpha-table binders + '#:hi-color hi-color + '#:hi-stxs (if (send config get-highlight-foci?) foci null) + '#:hi2-color "WhiteSmoke" + '#:hi2-stxs (if (send config get-highlight-frontier?) frontier null))) - ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void - (define/private (insert-syntax/redex stx foci binders definites frontier) - (insert-syntax/color stx foci binders definites frontier "MistyRose")) + ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void + (define/private (insert-syntax/redex stx foci binders definites frontier) + (insert-syntax/color stx foci binders definites frontier "MistyRose")) - ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void - (define/private (insert-syntax/contractum stx foci binders definites frontier) - (insert-syntax/color stx foci binders definites frontier "LightCyan")) + ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void + (define/private (insert-syntax/contractum stx foci binders definites frontier) + (insert-syntax/color stx foci binders definites frontier "LightCyan")) - ;; insert-step-separator : string -> void - (define/private (insert-step-separator text) - (send sbview add-text "\n ") - (send sbview add-text - (make-object image-snip% - (build-path (collection-path "icons") - "red-arrow.bmp"))) - (send sbview add-text " ") - (send sbview add-text text) - (send sbview add-text "\n\n")) + ;; insert-step-separator : string -> void + (define/private (insert-step-separator text) + (send sbview add-text "\n ") + (send sbview add-text + (make-object image-snip% + (build-path (collection-path "icons") + "red-arrow.bmp"))) + (send sbview add-text " ") + (send sbview add-text text) + (send sbview add-text "\n\n")) - ;; insert-as-separator : string -> void - (define/private (insert-as-separator text) - (send sbview add-text "\n ") - (send sbview add-text text) - (send sbview add-text "\n\n")) + ;; insert-as-separator : string -> void + (define/private (insert-as-separator text) + (send sbview add-text "\n ") + (send sbview add-text text) + (send sbview add-text "\n\n")) - ;; insert-step-separator/small : string -> void - (define/private (insert-step-separator/small text) - (send sbview add-text " ") - (send sbview add-text - (make-object image-snip% - (build-path (collection-path "icons") - "red-arrow.bmp"))) - (send sbview add-text " ") - (send sbview add-text text) - (send sbview add-text "\n\n")) + ;; insert-step-separator/small : string -> void + (define/private (insert-step-separator/small text) + (send sbview add-text " ") + (send sbview add-text + (make-object image-snip% + (build-path (collection-path "icons") + "red-arrow.bmp"))) + (send sbview add-text " ") + (send sbview add-text text) + (send sbview add-text "\n\n")) - )) - - ) + )) diff --git a/collects/macro-debugger/view/view.ss b/collects/macro-debugger/view/view.ss index 64b6467..120ad30 100644 --- a/collects/macro-debugger/view/view.ss +++ b/collects/macro-debugger/view/view.ss @@ -1,43 +1,41 @@ -(module view mzscheme - (require (lib "class.ss") - (lib "pretty.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - "interfaces.ss" - "frame.ss" - "prefs.ss" - "../model/trace.ss") - (provide (all-defined)) +#lang scheme/base +(require scheme/class + scheme/pretty + scheme/gui + framework/framework + "interfaces.ss" + "frame.ss" + "prefs.ss" + "../model/trace.ss") +(provide (all-defined-out)) - (define macro-stepper-frame% - (macro-stepper-frame-mixin - (frame:standard-menus-mixin - (frame:basic-mixin frame%)))) +(define macro-stepper-frame% + (macro-stepper-frame-mixin + (frame:standard-menus-mixin + (frame:basic-mixin frame%)))) - ;; Main entry points +;; Main entry points - (define (make-macro-stepper) - (let ([f (new macro-stepper-frame% - (config (new macro-stepper-config/prefs%)))]) - (send f show #t) - (send f get-widget))) +(define (make-macro-stepper) + (let ([f (new macro-stepper-frame% + (config (new macro-stepper-config/prefs%)))]) + (send f show #t) + (send f get-widget))) - (define (go stx) - (let ([stepper (make-macro-stepper)]) - (send stepper add-deriv (trace stx)) - stepper)) +(define (go stx) + (let ([stepper (make-macro-stepper)]) + (send stepper add-deriv (trace stx)) + stepper)) - (define (go/deriv deriv) - (let* ([f (new macro-stepper-frame%)] - [w (send f get-widget)]) - (send w add-deriv deriv) - (send f show #t) - w)) +(define (go/deriv deriv) + (let* ([f (new macro-stepper-frame%)] + [w (send f get-widget)]) + (send w add-deriv deriv) + (send f show #t) + w)) - (define (go/trace events) - (let* ([w (make-macro-stepper)]) - (send w add-trace events) - w)) - - ) +(define (go/trace events) + (let* ([w (make-macro-stepper)]) + (send w add-trace events) + w))