diff --git a/collects/macro-debugger/doc.txt b/collects/macro-debugger/doc.txt index bea0399f95..33079987d1 100644 --- a/collects/macro-debugger/doc.txt +++ b/collects/macro-debugger/doc.txt @@ -26,17 +26,70 @@ syntax browser uses colors and a properties panel to show the term's syntax properties, such as lexical binding information and source location. -_expand.ss_ -=========== +_stepper.ss_ +============ -> (require (lib "expand.ss" "macro-debugger")) +> (require (lib "stepper.ss" "macro-debugger")) This module provides a single procedure: > (expand/step syntax-or-sexpr) Expands the syntax (or S-expression) and opens a macro stepper frame -for stepping through the expansion. +for stepping through the expansion. + +_expand.ss_ +=========== + +> (require (lib "expand.ss" "macro-debugger")) + +This module provides the following procedures: + +> expand/step + +This export will disappear in a future version of the collection. +Require from stepper.ss instead. + +> (expand-only syntax list-of-identifiers) + +Expands the given syntax, but only shows the expansion of macros in +the given identifier list. + +Warning: because of limitations in syntax, expansion, and hiding, the +resulting syntax may not evaluate to the same thing as the original +syntax. + +> (expand/hide syntax list-of-identifier) + +Expands the given syntax, but hides the expansion of macros in the +given identifier list (conceptually, the complement of expand-only). + +Warning: because of limitations in syntax, expansion, and hiding, the +resulting syntax may not evaluate to the same thing as the original +syntax. + +_stepper-text.ss_ +================= + +> (require (lib "stepper-text.ss" "macro-debugger")) + +This module provides two procedures for stepping through macro +expansion in text-only environments. + +> (expand/step-text syntax [identifier-predicate]) + +Expands the syntax and prints the macro expansion steps. If the +identifier predicate is given, it determines which macros are shown +(if absent, no macros are hidden). A list of identifiers is also +accepted. + +> (stepper-text syntax [identifier-predicate]) + +Returns a procedure P that: + - when called with no arguments (or on the symbol 'next), + prints out individual steps until macro expansion finishes + - when called on the symbol 'all, + prints out all of the remaining steps _syntax-browser.ss_ =================== diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss index 1d52b224c3..46acecb4de 100644 --- a/collects/macro-debugger/expand.ss +++ b/collects/macro-debugger/expand.ss @@ -1,9 +1,32 @@ (module expand mzscheme - (require (lib "unitsig.ss")) - (require "view/view.ss") + (require "model/trace.ss" + "model/hide.ss") + (provide expand-only + expand/hide) + (provide expand/step) - - (define (expand/step stx) - (go stx)) + (define (expand/step . args) + (apply (dynamic-require '(lib "stepper.ss" "macro-debugger") 'expand/step) + args)) + + (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))) + ) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 4cf815a949..7b528d10f2 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -60,6 +60,8 @@ $2] [(visit (? TaggedPrimStep 'prim) return) ($2 $1)] + [(visit VariableStep return) + ($2 $1 $3)] [((? EE/Macro)) $1]) (EE/Macro @@ -127,9 +129,10 @@ ;; MacroStep Answer = Transformation (I,E) (MacroStep [(Resolves enter-macro + (! 'bad-transformer) macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform exit-macro) - (make-transformation $2 $7 $1 $3 $6 $4)]) + (make-transformation $2 $8 $1 $4 $7 $5)]) ;; Local actions taken by macro ;; LocalAction Answer = (list-of LocalAction) @@ -163,10 +166,14 @@ (PrimStep (#:no-wrap) [(Resolves NoError enter-prim (? Prim) exit-prim) - ($4 $3 $5 $1)] - [(Resolves variable) - (make-p:variable (car $2) (cdr $2) $1)]) + ($4 $3 $5 $1)]) + (VariableStep + (#:no-wrap) + (#:args e1 e2) + [(Resolves variable) + (make-p:variable e1 e2 $1)]) + ;; Tagged Primitive syntax ;; TaggedPrimStep Answer = syntax -> PRule (TaggedPrimStep @@ -174,6 +181,8 @@ (#:args orig-stx) [(Resolves ! IMPOSSIBLE) (make-p:unknown orig-stx #f $1)] + [(Resolves NoError enter-prim ! IMPOSSIBLE) + (make-p:unknown orig-stx #f $1)] [(Resolves NoError enter-prim (? TaggedPrim) exit-prim) ($4 orig-stx $5 $1 $3)]) @@ -234,7 +243,10 @@ (Prim#%ModuleBegin (#:args e1 e2 rs) - [(prim-#%module-begin ! (? ModulePass1 'pass1) next-group (? ModulePass2 'pass2)) + [(prim-#%module-begin (! 'malformed) + (? ModulePass1 'pass1) next-group + (? ModulePass2 'pass2) + (! 'provides)) (make-p:#%module-begin e1 e2 rs $3 $5)]) (ModulePass1 diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index 02454c89ee..ab82cb8fa0 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -489,10 +489,11 @@ (parameterize ((subterms-table subterms)) (match (seek d) [(and (struct error-wrap (exn tag inner)) ew) - (values ew (deriv-e2 inner))] + (values ew #f) + #;(values ew (deriv-e2 inner))] [deriv (values (rewrap d deriv) (lift/deriv-e2 deriv))])))])) - + ;; seek : Derivation -> Derivation ;; Expects macro-policy, subterms-table to be set up already (define (seek d) @@ -513,7 +514,7 @@ [subterms (filter (lambda (x) (not (error? x))) subterm-derivs)]) ;(printf "subterm paths:~n~s~n" (map s:subterm-path subterm-derivs)) ;(printf "subterms:~n~s~n" subterm-derivs) - (let ([e2 (substitute-subterms e1 subterms)]) + (let ([e2 (and (null? errors) (substitute-subterms e1 subterms))]) (let ([d (make-p:synth e1 e2 null subterms)]) (if (pair? errors) (rewrap (car errors) d) @@ -529,7 +530,7 @@ [(AnyQ deriv (e1 e2)) (let ([paths (table-get (subterms-table) e1)]) (cond [(null? paths) - (for-unlucky-deriv d)] + (for-unlucky-deriv/record-error d)] [(null? (cdr paths)) (let-values ([(d _) (hide d)]) (list (make-s:subterm (car paths) d)))] @@ -541,6 +542,14 @@ (raise (make-nonlinearity "nonlinearity in original term" paths))]))] [#f null])) + ;; for-unluck-deriv/record-error -> (list-of Subterm) + ;; Guarantee: (deriv-e1 deriv) is not in subterms table + (define (for-unlucky-deriv/record-error d) + (if (error-wrap? d) + (append (for-unlucky-deriv d) + (list (make-s:subterm #f d))) + (for-unlucky-deriv d))) + ;; for-unlucky-deriv : Derivation -> (list-of Subterm) ;; Guarantee: (deriv-e1 deriv) is not in subterms table (define (for-unlucky-deriv d) @@ -638,7 +647,7 @@ [(AnyQ mrule (e1 e2 (and ew (struct error-wrap (_ _ _))) next)) (list (make-s:subterm #f ew))] - + [(AnyQ lift-deriv (e1 e2 first lifted-stx next)) (>>Seek (for-deriv first) (for-deriv next))] diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 69e51a3744..4f550d1013 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -29,7 +29,9 @@ ;; Primitives [(struct p:variable (e1 e2 rs)) - null] + (if (bound-identifier=? e1 e2) + null + (list (walk e1 e2 "Resolve variable (remove extra marks)")))] [(IntQ p:module (e1 e2 rs #f body)) (with-syntax ([(?module name language . BODY) e1]) (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))] @@ -42,21 +44,19 @@ (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]) (with-context ctx (reductions body))))] - [(IntQ p:#%module-begin (e1 e2 rs pass1 pass2)) - #;(R e1 (?module-begin . MBODY) - [! exni 'blah] - [ModulePass1 MBODY pass1] - => (lambda (e1prime) - (R e1prime (?module-begin2 . MBODY2) - [ModulePass2 MBODY2 pass2]))) + [(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2)) (with-syntax ([(?#%module-begin form ...) e1]) - (let-values ([(reductions1 final-stxs1) - (with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x))) - (mbrules-reductions pass1 (syntax->list #'(form ...)) #t))]) - (let-values ([(reductions2 final-stxs2) - (with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x))) - (mbrules-reductions pass2 final-stxs1 #f))]) - (append reductions1 reductions2))))] + (let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))]) + (let-values ([(reductions1 final-stxs1) + (with-context frame + (mbrules-reductions pass1 (syntax->list #'(form ...)) #t))]) + (let-values ([(reductions2 final-stxs2) + (with-context frame + (mbrules-reductions pass2 final-stxs1 #f))]) + (if (error-wrap? d) + (append reductions1 reductions2 + (list (stumble (frame final-stxs2) (error-wrap-exn d)))) + (append reductions1 reductions2))))))] [(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni) (R e1 _ [! exni] @@ -269,7 +269,8 @@ [#f null] - #;[else (error 'reductions "unmatched case: ~s" d)])) + #; + [else (error 'reductions "unmatched case: ~s" d)])) ;; reductions-transformation : Transformation -> ReductionSequence (define (reductions-transformation tx) @@ -279,6 +280,8 @@ (list (walk e1 e2 "Macro transformation")))] [(IntW transformation (e1 e2 rs me1 me2 locals) 'locals) (reductions-locals e1 locals)] + [(ErrW transformation (e1 e2 rs me1 me2 locals) 'bad-transformer exn) + (list (stumble e1 exn))] [(ErrW transformation (e1 e2 rs me1 me2 locals) 'transform exn) (append (reductions-locals e1 locals) (list (stumble e1 exn)))])) @@ -374,7 +377,9 @@ [(cons (struct b:splice (renames head tail)) next) (loop next tail prefix (cons (list (walk/foci (deriv-e2 head) - (take-until tail (stx-cdr suffix)) + (stx-take tail + (- (stx-improper-length tail) + (stx-improper-length (stx-cdr suffix)))) (E (revappend prefix (cons (deriv-e2 head) (stx-cdr suffix)))) (E (revappend prefix tail)) diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.ss index 56339f4471..1c34aaf7a2 100644 --- a/collects/macro-debugger/model/stx-util.ss +++ b/collects/macro-debugger/model/stx-util.ss @@ -80,15 +80,6 @@ (cond [(zero? n) null] [else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) - (define *args* #f) - - (define (take-until stxs tail) - (set! *args* (list stxs tail)) - (let loop ([stxs stxs]) - (if (eq? stxs tail) - null - (cons (stx-car stxs) (loop (stx-cdr stxs)))))) - (define (stx-improper-length stx) (if (stx-pair? stx) (add1 (stx-improper-length (stx-cdr stx))) diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss new file mode 100644 index 0000000000..acef02d720 --- /dev/null +++ b/collects/macro-debugger/stepper-text.ss @@ -0,0 +1,139 @@ + +(module stepper-text mzscheme + (require (lib "list.ss") + (lib "pretty.ss") + "model/trace.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 + (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 + [() (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-note step)) + (newline) + (show-term (step-e1 step) partition) + (display " ==>") + (newline) + (show-term (step-e2 step) partition) + (newline)] + [(misstep? step) + (display (exn-message (misstep-exn step))) + (newline) + (show-term (misstep-e1 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 extended-style-list + '((define-values . define) + (define-syntaxes . define-syntax))) + ) \ No newline at end of file diff --git a/collects/macro-debugger/stepper.ss b/collects/macro-debugger/stepper.ss new file mode 100644 index 0000000000..cc3d64d010 --- /dev/null +++ b/collects/macro-debugger/stepper.ss @@ -0,0 +1,9 @@ + +(module stepper mzscheme + (require "view/view.ss") + (provide expand/step) + + (define (expand/step stx) + (go stx)) + + ) diff --git a/collects/macro-debugger/syntax-browser/hrule-snip.ss b/collects/macro-debugger/syntax-browser/hrule-snip.ss index 9d3ce56836..fb45593fa0 100644 --- a/collects/macro-debugger/syntax-browser/hrule-snip.ss +++ b/collects/macro-debugger/syntax-browser/hrule-snip.ss @@ -16,7 +16,7 @@ [ad-y (box 0)]) (send (get-admin) get-view-size ad-x ad-y) #;(set-box?! bw fw) - (set-box?! bw (unbox ad-x)) + (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)) @@ -30,5 +30,28 @@ (set! cached-xheight h) h))) (define cached-xheight #f) + + ;; 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) ) diff --git a/collects/macro-debugger/syntax-browser/implementation.ss b/collects/macro-debugger/syntax-browser/implementation.ss index 50c37f2d65..7562b936e2 100644 --- a/collects/macro-debugger/syntax-browser/implementation.ss +++ b/collects/macro-debugger/syntax-browser/implementation.ss @@ -9,6 +9,8 @@ "prefs.ss") (provide global-prefs@ global-snip@ + widget-keymap@ + widget-context-menu@ implementation@) (provide-signature-elements snip^) (provide-signature-elements snipclass^) @@ -16,15 +18,22 @@ ;; prefs@ and snip@ should only be invoked once ;; We create a new unit/sig out of their invocation + (define snip-keymap@ + (compound-unit/sig + (import [MENU : context-menu^] + [SNIP : snip^]) + (link [KEYMAP : keymap^ (keymap@ MENU SNIP)] + [SNIP-KEYMAP : keymap^ (snip-keymap-extension@ KEYMAP)]) + (export (open SNIP-KEYMAP)))) + (define snip-implementation@ (compound-unit/sig (import) - (link [PREFS : prefs^ (prefs@)] - [KEYMAP : keymap^ (keymap@)] - [MENU : context-menu^ (context-menu@ SNIP)] - [SNIP-CLASS : snipclass^ (snipclass@ SNIP)] - [SNIP-MENU : context-menu^ (snip-context-menu-extension@ MENU)] - [SNIP : snip^ (snip@ PREFS KEYMAP SNIP-MENU SNIP-CLASS)]) + (link [PREFS : prefs^ (prefs@)] + [MENU : context-menu^ (context-menu@)] + [KEYMAP : keymap^ (snip-keymap@ MENU SNIP)] + [SNIP-CLASS : snipclass^ (snipclass@ SNIP)] + [SNIP : snip^ (snip@ PREFS KEYMAP MENU SNIP-CLASS)]) (export (open PREFS) (open SNIP) (open SNIP-CLASS)))) (define-values/invoke-unit/sig ((open snip^) (open prefs^) (open snipclass^)) snip-implementation@) @@ -49,16 +58,30 @@ ;; Everyone else re-uses the global-snip@ unit - ;; implementation@ : prefs^ -> implementation^ + (define widget-keymap@ + (compound-unit/sig + (import [MENU : context-menu^] + [SNIP : snip^]) + (link [KEYMAP : keymap^ (keymap@ MENU SNIP)] + [WKEYMAP : keymap^ (widget-keymap-extension@ KEYMAP)]) + (export (open WKEYMAP)))) + + (define widget-context-menu@ + (compound-unit/sig + (import) + (link [MENU : context-menu^ (context-menu@)] + [WMENU : context-menu^ (widget-context-menu-extension@ MENU)]) + (export (open WMENU)))) + + ;; implementation@ : implementation^ (define implementation@ (compound-unit/sig (import) - (link [KEYMAP : keymap^ (keymap@)] - [MENU : context-menu^ (context-menu@ SNIP)] - [SNIP : snip^ (global-snip@)] - [WIDGET-MENU : context-menu^ (widget-context-menu-extension@ MENU)] - [WIDGET : widget^ (widget@ KEYMAP WIDGET-MENU)]) + (link [SNIP : snip^ (global-snip@)] + [MENU : context-menu^ (widget-context-menu@)] + [KEYMAP : keymap^ (widget-keymap@ MENU SNIP)] + [WIDGET : widget^ (widget@ KEYMAP)]) (export (unit SNIP snip) (unit WIDGET widget)))) - + ) diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss index 503c0564ea..79e8480642 100644 --- a/collects/macro-debugger/syntax-browser/keymap.ss +++ b/collects/macro-debugger/syntax-browser/keymap.ss @@ -8,72 +8,30 @@ (provide keymap@ context-menu@) - (define keymap@ - (unit/sig keymap^ - (import) - - (define syntax-keymap% - (class keymap% - (init editor) - (init-field context-menu) - - (inherit add-function - map-function - chain-to-keymap) - (super-new) - - ;; Initialization - (map-function "rightbutton" "popup-context-window") - (add-function "popup-context-window" - (lambda (editor event) - (do-popup-context-window editor event))) - - ;; Attach to editor - (chain-to-keymap (send editor get-keymap) #t) - (send editor set-keymap this) - - (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 context-menu x y)))))) - (define context-menu@ (unit/sig context-menu^ - (import snip^) + (import) (define context-menu% (class popup-menu% + (init-field keymap) (init-field controller) (super-new) - - (define copy-menu #f) - (define copy-syntax-menu #f) - (define clear-menu #f) + + (field [copy-menu #f] + [copy-syntax-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) - (define stx (send controller get-selected-syntax)) - (send the-clipboard set-clipboard-string - (if stx - (format "~s" (syntax-object->datum stx)) - "") - (send e get-time-stamp)))))) + (send keymap call-function "copy-text" i e))))) (set! copy-syntax-menu (new menu-item% (label "Copy syntax") (parent this) (callback (lambda (i e) - (define stx (send controller get-selected-syntax)) - (define t (new text%)) - (send t insert - (new syntax-snip% - (syntax stx) - #;(controller controller))) - (send t select-all) - (send t copy))))) + (send keymap call-function "copy-syntax" i e))))) (void)) (define/public (after-edit-items) @@ -84,7 +42,16 @@ (new menu-item% (label "Clear selection") (parent this) - (callback (lambda _ (send controller select-syntax #f))))) + (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) @@ -113,7 +80,7 @@ (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)) @@ -134,4 +101,75 @@ (after-partition-items) )))) + + (define keymap@ + (unit/sig keymap^ + (import context-menu^ snip^) + + (define syntax-keymap% + (class keymap% + (init editor) + (init-field controller) + + (inherit add-function + map-function + chain-to-keymap) + (super-new) + + (define context-menu (make-context-menu)) + + (define/public (make-context-menu) + (new context-menu% (controller controller) (keymap this))) + + ;; Key mappings + + (map-function "rightbutton" "popup-context-window") + + ;; Functionality + + (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-syntax" + (lambda (_ event) + (define stx (send controller get-selected-syntax)) + (define t (new text%)) + (send t insert + (new syntax-snip% + (syntax stx))) + (send t select-all) + (send t copy))) + + (add-function "clear-syntax-selection" + (lambda (i e) + (send controller select-syntax #f))) + + (add-function "show-syntax-properties" + (lambda (i e) + (error 'show-syntax-properties "not provided by this keymap"))) + + ;; Attach to editor + + (chain-to-keymap (send editor get-keymap) #t) + (send editor set-keymap this) + + (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 context-menu x y)))))) ) diff --git a/collects/macro-debugger/syntax-browser/params.ss b/collects/macro-debugger/syntax-browser/params.ss index f952b87c76..f440241310 100644 --- a/collects/macro-debugger/syntax-browser/params.ss +++ b/collects/macro-debugger/syntax-browser/params.ss @@ -1,7 +1,9 @@ (module params mzscheme (provide current-syntax-font-size - current-default-columns) + current-default-columns + current-colors + current-suffix-option) ;; current-syntax-font-size : parameter of number/#f ;; When non-false, overrides the default font size @@ -9,5 +11,17 @@ ;; current-default-columns : parameter of number (define current-default-columns (make-parameter 60)) + + ;; current-suffix-option : parameter of SuffixOption + (define current-suffix-option (make-parameter 'over-limit)) + + (define current-colors + (make-parameter + (list "black" "red" "blue" + "mediumforestgreen" "darkgreen" + "darkred" + "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue" + "indigo" "purple" + "orange" "salmon" "darkgoldenrod" "olive"))) ) diff --git a/collects/macro-debugger/syntax-browser/partition.ss b/collects/macro-debugger/syntax-browser/partition.ss index 8a25624779..3adc7e403d 100644 --- a/collects/macro-debugger/syntax-browser/partition.ss +++ b/collects/macro-debugger/syntax-browser/partition.ss @@ -9,10 +9,7 @@ identifier=-choices) (define (new-bound-partition) - #;(define p (new partition% (relation id:same-marks?))) - (define p (new bound-partition%)) - (send p get-partition (datum->syntax-object #f 'no-marks)) - p) + (new bound-partition%)) ;; representative-symbol : symbol ;; Must be fresh---otherwise, using it could detect rename wraps @@ -74,7 +71,8 @@ rep=>num (lambda (k v) (printf "~s => ~s~n" k v)))) - + + (get-partition unmarked-syntax) (super-new) )) @@ -90,8 +88,9 @@ [n (bound-identifier-mapping-get numbers r (lambda _ #f))]) (or n (begin0 next-number - (bound-identifier-mapping-put! numbers r next-number) - (set! next-number (add1 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))) @@ -101,7 +100,8 @@ (define/private (representative stx) (datum->syntax-object stx representative-symbol)) - + + (get-partition unmarked-syntax) (super-new))) ;; Different identifier relations for highlighting. diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index e9cc88da3e..12766e0575 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -19,11 +19,16 @@ (define-struct syntax-dummy (val)) - ;; syntax->datum/tables : stx [partition% num boolean] + ;; 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 - ;; When numbering? is true, suffixes identifiers with partition numbers. ;; ;; Returns three values: ;; - an S-expression @@ -32,18 +37,23 @@ ;; Syntax objects which are eq? will map to same flat values (define syntax->datum/tables (case-lambda - [(stx) (table stx #f #f #f)] - [(stx partition limit numbering?) (table stx partition limit numbering?)])) + [(stx) (table stx #f #f 'never)] + [(stx partition limit suffixopt) (table stx partition limit suffixopt)])) - ;; table : syntax partition%-or-#f num-or-#f -> (values s-expr hashtable hashtable) - (define (table stx partition limit numbering?) + ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) + (define (table stx partition limit suffixopt) (define (make-identifier-proxy id) - (let ([n (send partition get-partition id)]) - (cond [(or (zero? n) (not numbering?)) - (string->uninterned-symbol (symbol->string (syntax-e id)))] - [else - (string->uninterned-symbol - (format "~a:~a" (syntax-e id) n))]))) + (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)]) @@ -51,10 +61,11 @@ (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)]) - (when (and limit (> (send partition count) limit)) - (call-with-values (lambda () (table stx partition #f #t)) - escape)) (hash-table-put! flat=>stx lp-datum obj) (hash-table-put! stx=>flat obj lp-datum) lp-datum)] @@ -69,8 +80,7 @@ [(vector? obj) (list->vector (map loop (vector->list obj)))] [(symbol? obj) - ;(make-syntax-dummy obj) - (string->uninterned-symbol (symbol->string obj))] + (unintern obj)] [(number? obj) (make-syntax-dummy obj)] [(box? obj) @@ -90,4 +100,11 @@ (values (loop stx) flat=>stx stx=>flat)))) + + (define (unintern sym) + (string->uninterned-symbol (symbol->string sym))) + + (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 1cd5d369e1..1260952bce 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -97,7 +97,9 @@ ;; recompute-tables : -> void (define/private (recompute-tables) (set!-values (datum ht:flat=>stx ht:stx=>flat) - (syntax->datum/tables main-stx primary-partition 12 #f)) + (syntax->datum/tables main-stx primary-partition + (length (current-colors)) + (current-suffix-option))) (set! identifier-list (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))) diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss index 00965ea336..24ea7e3d49 100644 --- a/collects/macro-debugger/syntax-browser/properties.ss +++ b/collects/macro-debugger/syntax-browser/properties.ss @@ -12,10 +12,12 @@ (init parent) (define selected-syntax #f) + (define tab-choices (get-tab-choices)) (define tab-panel (new tab-panel% - (choices (list "Binding" "Source" "Properties")) + (choices (map car tab-choices)) (parent parent) (callback (lambda _ (refresh))))) + (define text (new text%)) (send text set-styles-sticky #f) (define ecanvas (new editor-canvas% (editor text) (parent tab-panel))) @@ -24,63 +26,106 @@ (set! selected-syntax stx) (refresh)) + ;; get-tab-choices : (listof (cons string thunk)) + ;; Override to add or remove panels + (define/public (get-tab-choices) + (list (cons "Term" (lambda () (display-meaning-info))) + (cons "Syntax Object" (lambda () (display-stxobj-info))))) + (define/private (refresh) (send* text (lock #f) (begin-edit-sequence) (erase)) (when (syntax? selected-syntax) - (let ([s (send tab-panel get-item-label (send tab-panel get-selection))]) - (cond [(equal? s "Binding") - (display-binding-info)] - [(equal? s "Source") - (display-source-info)] - [(equal? s "Properties") - (display-properties)]))) + (let ([tab (send tab-panel get-item-label (send tab-panel get-selection))]) + (cond [(assoc tab tab-choices) => (lambda (p) ((cdr p)))] + [else (error 'properties-view%:refresh "internal error: no such tab: ~s" tab)]))) (send* text (end-edit-sequence) (lock #t) (scroll-to-position 0))) + (define/pubment (display-meaning-info) + (when (and (identifier? selected-syntax) + (uninterned? (syntax-e selected-syntax))) + (display "Uninterned symbol!\n\n" key-sd)) + (display-binding-info) + (inner (void) display-meaning-info)) + + (define/private (display-binding-info) - (for-each (lambda (p) (display-binding-kv (car p) ((cdr p) selected-syntax))) - binding-properties)) - - (define/private (display-binding-kv k v) - (display (format "~a~n" k) key-sd) - (cond [(eq? v 'lexical) - (display "lexical\n" #f)] - [(eq? v #f) - (display "#f (top-level or unbound)\n" #f)] + (display "Apparent identifier binding\n" key-sd) + (unless (identifier? selected-syntax) + (display "Not applicable\n\n" n/a-sd)) + (when (identifier? selected-syntax) + (if (eq? (identifier-binding selected-syntax) 'lexical) + (display "lexical (all phases)\n" #f) + (for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) selected-syntax))) + binding-properties)) + (display "\n" #f))) + + (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 "source module" (mpi->string (list-ref v 0))) - (display-subkv "source id" (list-ref v 1)) - (display-subkv "nom. module" (mpi->string (list-ref v 2))) - (display-subkv "nom. id" (list-ref v 3)) + (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-subkv "phase" "via define-for-syntax"))] - [(void? v) - (display "Not applicable\n" n/a-sd)]) - (display "\n" #f)) + (display " via define-for-syntax" sub-key-sd))])) + + (define/pubment (display-stxobj-info) + (display-source-info) + (display-extra-source-info) + (inner (void) display-stxobj-info) + (display-symbol-property-info)) - (define/private (display-subkv k v) - (display (format "~a: " k) sub-key-sd) - (display (format "~a~n" v) #f)) - (define/private (display-source-info) - (for-each (lambda (p) (display-subkv (car p) ((cdr p) selected-syntax))) - source-properties)) + (define s-source (syntax-source selected-syntax)) + (define s-line (syntax-line selected-syntax)) + (define s-column (syntax-column selected-syntax)) + (define s-position (syntax-position selected-syntax)) + (define s-span0 (syntax-span selected-syntax)) + (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)) - (define/private (display-properties) + (define/private (display-extra-source-info) + (display "Built-in properties\n" key-sd) + (display-subkv "source module" + (let ([mod (syntax-source-module selected-syntax)]) + (and mod (mpi->string mod)))) + (display-subkv "original?" (syntax-original? selected-syntax)) + (display "\n" #f)) + + (define/private (display-symbol-property-info) (let ([keys (syntax-property-symbol-keys selected-syntax)]) - (if (null? keys) - (display "No properties available" n/a-sd) - (for-each (lambda (k) (display-kv k (syntax-property selected-syntax k))) - keys)))) - + (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 k (syntax-property selected-syntax k))) + keys)))) + (define/private (display-kv key value) (display (format "~a~n" key) key-sd) (display (format "~s~n~n" value) #f)) + + (define/public (display-subkv k v) + (display (format "~a: " k) sub-key-sd) + (display (format "~a~n" v) #f)) (define/private (display item sd) (let ([p0 (send text last-position)]) @@ -97,23 +142,23 @@ ;; binding-properties : (listof (cons string (syntax -> any))) (define binding-properties - (list (cons "identifier-binding" + (list (cons "in the standard phase" (lift/id identifier-binding)) - (cons "identifier-transformer-binding" + (cons "in the transformer phase (\"for-syntax\")" (lift/id identifier-transformer-binding)) - (cons "identifier-template-binding" + (cons "in the template phase (\"for-template\")" (lift/id identifier-template-binding)))) + + (define (uninterned? s) + (not (eq? s (string->symbol (symbol->string s))))) - ;; source-properties : (listof (cons string (syntax -> any))) - (define source-properties - (list (cons "syntax-source" syntax-source) - (cons "syntax-source-module" - (lambda (stx) (mpi->string (syntax-source-module stx)))) - (cons "syntax-line" syntax-line) - (cons "syntax-position" syntax-position) - (cons "syntax-span" syntax-span) - (cons "syntax-original?" syntax-original?))) - + (define (prettify-source s) + (cond [(is-a? s editor<%>) + 'editor] + [else s])) + + ;; Styles + (define key-sd (let ([sd (new style-delta%)]) (send sd set-delta-foreground "blue") @@ -130,4 +175,4 @@ (send sd set-delta-foreground "gray") sd)) - ) \ No newline at end of file + ) diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index 2ca4373a98..440e02be49 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -9,7 +9,7 @@ "properties.ss" "typesetter.ss") (provide snip@ - snip-context-menu-extension@) + snip-keymap-extension@) (define snip@ (unit/sig snip^ @@ -48,7 +48,7 @@ (send -outer change-style (make-object style-delta% 'change-alignment 'top)) (new syntax-keymap% (editor -outer) - (context-menu (new context-menu% (snip this)))) + (snip this)) (refresh) (define/public (get-controller) controller) @@ -200,6 +200,21 @@ (super-new))) )) + (define snip-keymap-extension@ + (unit/sig keymap^ + (import (pre : keymap^)) + + (define syntax-keymap% + (class pre:syntax-keymap% + (init-field snip) + (inherit add-function) + (super-new (controller (send snip get-controller))) + + (add-function "show-syntax-properties" + (lambda (i e) + (send snip show-props))))))) + + #; (define snip-context-menu-extension@ (unit/sig context-menu^ (import (pre : context-menu^)) diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.ss index e527f94c79..9f679ada68 100644 --- a/collects/macro-debugger/syntax-browser/util.ss +++ b/collects/macro-debugger/syntax-browser/util.ss @@ -25,7 +25,7 @@ (format "~s" (car mps))] [(null? mps) "self"])) (format "~s" mpi))) - + (define (mpi->list mpi) (if mpi (let-values ([(path rel) (module-path-index-split mpi)]) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 2cd897823f..91c541fac6 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -13,12 +13,12 @@ "properties.ss" "util.ss") (provide widget@ + widget-keymap-extension@ widget-context-menu-extension@) (define widget@ (unit/sig widget^ - (import keymap^ - context-menu^) + (import keymap^) ;; syntax-widget% ;; A syntax-widget creates its own syntax-controller. @@ -39,12 +39,11 @@ (new syntax-controller% (properties-controller this))) - (define/public (make-context-menu) - (new context-menu% (widget this))) - - (new syntax-keymap% - (editor -text) - (context-menu (make-context-menu))) + (define/public (make-keymap text) + (new syntax-keymap% + (editor text) + (widget this))) + (make-keymap -text) (send -text lock #t) (send -split-panel set-percentages @@ -56,32 +55,27 @@ (define/public (set-syntax stx) (send props set-syntax stx)) - (define/public (show ?) - (if ? (show-props) (hide-props))) - (define/public (props-shown?) (send -props-panel is-shown?)) (define/public (toggle-props) - (if (send -props-panel is-shown?) - (hide-props) - (show-props))) - - (define/public (hide-props) - (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) - (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))) + (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 (get-controller) controller) ;; @@ -145,32 +139,41 @@ )) + (define widget-keymap-extension@ + (unit/sig keymap^ + (import (pre : keymap^)) + + (define syntax-keymap% + (class pre:syntax-keymap% + (init-field widget) + (super-new (controller (send widget get-controller))) + (inherit add-function) + + (add-function "show-syntax-properties" + (lambda (i e) + (send widget toggle-props))) + + (define/public (get-widget) widget) + )))) + (define widget-context-menu-extension@ (unit/sig context-menu^ (import (pre : context-menu^)) (define context-menu% (class pre:context-menu% - (init-field widget) - - (define props-menu #f) - - (define/override (after-selection-items) - (super after-selection-items) - (set! props-menu - (new menu-item% (label "Show/hide syntax properties") - (parent this) - (callback (lambda _ (send widget toggle-props))))) - (void)) + (inherit-field keymap) + (inherit-field props-menu) (define/override (on-demand) (send props-menu set-label - (if (send widget props-shown?) + (if (send (send keymap get-widget) props-shown?) "Hide syntax properties" "Show syntax properties")) (super on-demand)) - - (super-new (controller (send widget get-controller))))))) - - (define browser-text% (editor:standard-style-list-mixin text:basic%)) + (super-new))))) + + (define browser-text% + (text:hide-caret/selection-mixin + (editor:standard-style-list-mixin text:basic%))) ) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index 34bb23e7fb..76dc640b6c 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -14,21 +14,20 @@ "../model/deriv-util.ss" "../model/trace.ss" "../model/hide.ss" - "../model/hiding-policies.ss" "../model/steps.ss" "cursor.ss" "util.ss") - (provide catch-errors? - pre-stepper@ + (provide pre-stepper@ view@ context-menu-extension@ - browser-extension@) + browser-extension@ - ;; Configuration + catch-errors?) + + ;; Debugging parameters / Not user configurable (define catch-errors? (make-parameter #t)) - (define show-rename-steps? (make-parameter #f)) ;; Macro Stepper @@ -37,117 +36,147 @@ (import prefs^ view-base^ (sb : sb:widget^)) - - (define (default-policy) - (let ([p (new-hiding-policy)]) - (set-hiding-policy-opaque-kernel! p (pref:hide-primitives?)) - (set-hiding-policy-opaque-libs! p (pref:hide-libs?)) - p)) - + + (define macro-stepper-config% + (class object% + (field/notify width (notify-box/pref pref:width)) + (field/notify height (notify-box/pref pref:height)) + (field/notify macro-hiding? (notify-box/pref pref:macro-hiding?)) + (field/notify show-syntax-properties? + (notify-box/pref pref:show-syntax-properties?)) + (field/notify show-hiding-panel? + (notify-box/pref pref:show-hiding-panel?)) + (field/notify hide-primitives? + (notify-box/pref pref:hide-primitives?)) + (field/notify hide-libs? + (notify-box/pref pref:hide-libs?)) + (field/notify highlight-foci? + (notify-box/pref pref:highlight-foci?)) + (field/notify show-rename-steps? + (notify-box/pref pref:show-rename-steps?)) + (field/notify suppress-warnings? + (notify-box/pref pref:suppress-warnings?)) + (super-new))) + (define macro-stepper-frame% (class base-frame% - (init (policy (default-policy)) - (macro-hiding? (pref:macro-hiding?)) - (show-hiding-panel? (pref:show-hiding-panel?)) - (identifier=? (pref:identifier=?)) - (width (pref:width)) - (height (pref:height))) + (init (identifier=? (pref:identifier=?))) + (init-field (config (new macro-stepper-config%))) + (inherit get-menu% get-menu-item% get-menu-bar get-file-menu get-edit-menu get-help-menu) - + (super-new (label "Macro stepper") - (width width) - (height height)) + (width (send config get-width)) + (height (send config get-height))) (define/override (on-size w h) + (send config set-width w) + (send config set-height h) (send widget update/preserve-view)) - + (define/augment (on-close) - (pref:width (send this get-width)) - (pref:height (send this get-height)) (send widget shutdown) (inner (void) on-close)) - + (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? + ;file-menu:create-print? edit-menu:create-undo? edit-menu:create-redo? - ;edit-menu:create-cut? - ;edit-menu:create-paste? + ;edit-menu:create-cut? + ;edit-menu:create-paste? edit-menu:create-clear? - ;edit-menu:create-find? - ;edit-menu:create-find-again? + ;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 syntax-menu - (new (get-menu%) (parent (get-menu-bar)) (label "Syntax"))) (define stepper-menu (new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) (define help-menu (get-help-menu)) - - (define (mk-register-action menu) - (lambda (label callback) - (if label - (new (get-menu-item%) - (label label) (parent menu) (callback (lambda _ (callback)))) - (new separator-menu-item% (parent menu))))) - + (define widget (new macro-stepper-widget% (parent (send this get-area-container)) - (policy policy) - (macro-hiding? macro-hiding?) - (show-hiding-panel? show-hiding-panel?))) + (config config))) + (define/public (get-widget) widget) - (begin - (new (get-menu-item%) (label "Show/hide syntax properties") (parent syntax-menu) - (callback (lambda _ (send (send widget get-view) toggle-props)))) - (define id-menu - (new (get-menu%) (label "Identifier=?") (parent syntax-menu))) + ;; Set up menus + + (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) - on-update-identifier=? - (car p) - (cdr p)))))]) + (callback + (lambda _ + (send (send widget get-controller) + on-update-identifier=? + (car p) + (cdr p)))))]) (send (send widget get-controller) add-identifier=?-listener (lambda (new-name new-func) - (send this-choice check (eq? new-name (car p))))))) - (sb:identifier=-choices)) - (new (get-menu-item%) (label "Clear selection") (parent syntax-menu) - (callback - (lambda _ (send (send widget get-controller) select-syntax #f)))) - (new (get-menu-item%) - (label "Show/hide macro hiding configuration") - (parent stepper-menu) - (callback (lambda _ (send widget show/hide-macro-hiding-prefs))))) + (send this-choice check + (eq? new-name (car p))))))) + (sb:identifier=-choices))) + (when identifier=? + (let ([p (assoc identifier=? (sb:identifier=-choices))]) + (when p + (send (send widget get-controller) + on-update-identifier=? + (car p) + (cdr p))))) + + (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)) + (let ([extras-menu + (new (get-menu%) + (label "Extra options") + (parent stepper-menu))]) + (menu-option/notify-box extras-menu + "Highlight redex/contractum" + (get-field highlight-foci? config)) + (menu-option/notify-box extras-menu + "Include renaming steps" + (get-field show-rename-steps? config)) + (menu-option/notify-box extras-menu + "Suppress warnings" + (get-field suppress-warnings? config)) + (new checkable-menu-item% + (label "(Debug) Catch internal errors?") + (parent extras-menu) + (checked (catch-errors?)) + (callback + (lambda (c e) (catch-errors? (send c is-checked?)))))) - (begin - (when identifier=? - (let ([p (assoc identifier=? (sb:identifier=-choices))]) - (when p - (send (send widget get-controller) - on-update-identifier=? - (car p) - (cdr p)))))) - (frame:reorder-menus this) )) @@ -155,9 +184,7 @@ (define macro-stepper-widget% (class* object% () (init-field parent) - (init policy) - (init macro-hiding?) - (init show-hiding-panel?) + (init-field config) ;; derivs : (list-of Derivation) (define derivs null) @@ -168,16 +195,26 @@ ;; derivs-prefix : (list-of (cons Derivation Derivation)) (define derivs-prefix null) + ;; steps : cursor (define steps #f) + ;; zoomed? : boolean + (define zoomed? #f) + (define warnings-frame #f) (define/public (add-deriv d) (set! derivs (append derivs (list d))) - (when (and (not (send updown-navigator is-shown?)) + (when (and (not (send nav:up is-shown?)) (pair? (cdr (append derivs-prefix derivs)))) - (send super-navigator add-child updown-navigator) - (send updown-navigator show #t)) + (send navigator change-children + (lambda (_) + (list nav:up + nav:start + nav:previous + nav:next + nav:end + nav:down)))) (if (null? (cdr derivs)) ;; There is nothing currently displayed (refresh) @@ -188,41 +225,51 @@ (define/public (get-macro-hiding-prefs) macro-hiding-prefs) (define area (new vertical-panel% (parent parent))) - (define super-navigator + (define navigator (new horizontal-panel% (parent area) (stretchable-height #f) (alignment '(center center)))) - (define navigator + #; + (define advanced-navigator (new horizontal-panel% - (parent super-navigator) + (parent area) (stretchable-height #f) (alignment '(center center)))) - (define updown-navigator - (new horizontal-panel% - (parent super-navigator) - (style '(deleted)) - (stretchable-height #f) - (alignment '(center center)))) - + (define sbview (new sb:syntax-widget% (parent area) (macro-stepper this) (pref:props-percentage pref:props-percentage))) + (send sbview show-props (send config get-show-syntax-properties?)) + (send config listen-show-syntax-properties? + (lambda (show?) (send sbview show-props show?))) + (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% - (policy policy) (parent control-pane) (stepper this) - (enabled? macro-hiding?))) + (config config))) + (send config listen-show-hiding-panel? + (lambda (show?) (show-macro-hiding-prefs show?))) + (show-macro-hiding-prefs (send config get-show-hiding-panel?)) + (send sbc add-selection-listener (lambda (stx) (send macro-hiding-prefs set-syntax stx))) - (unless show-hiding-panel? - (show/hide-macro-hiding-prefs)) - + + (send config listen-highlight-foci? + (lambda (_) (update/preserve-view))) + + (send config listen-show-rename-steps? + (lambda (_) (refresh))) + + (define nav:up + (new button% (label "Previous term") (parent navigator) (style '(deleted)) + (callback (lambda (b e) (navigate-up))))) + (define nav:start (new button% (label "<-- Start") (parent navigator) (callback (lambda (b e) (navigate-to-start))))) @@ -236,20 +283,30 @@ (new button% (label "End -->") (parent navigator) (callback (lambda (b e) (navigate-to-end))))) - (define nav:up - (new button% (label "Previous term") (parent updown-navigator) - (callback (lambda (b e) (navigate-up))))) (define nav:down - (new button% (label "Next term") (parent updown-navigator) + (new button% (label "Next term") (parent navigator) (style '(deleted)) (callback (lambda (b e) (navigate-down))))) - (define/public (show/hide-macro-hiding-prefs) + #; + (define nav:zoom-in + (new button% (label "Zoom in") (parent advanced-navigator) + (callback (lambda (b e) (navigate-zoom-in))))) + #; + (define nav:zoom-out + (new button% (label "Zoom out") (parent advanced-navigator) + (callback (lambda (b e) (navigate-zoom-out))))) + #; + (define nav:jump-to + (new button% (label "Skip to") (parent advanced-navigator) + (callback (lambda (b e) (navigate-skip-to))))) + + (define/public (show-macro-hiding-prefs show?) (send area change-children (lambda (children) - (if (memq control-pane children) - (remq control-pane children) - (append children (list control-pane)))))) - + (if show? + (append (remq control-pane children) (list control-pane)) + (remq control-pane children))))) + ;; Navigate (define/private (navigate-to-start) @@ -278,6 +335,17 @@ (set! synth-deriv #f)) (refresh)) + (define/private (navigate-zoom-in) + (set! zoomed? #t) + (update)) + + (define/private (navigate-zoom-out) + (set! zoomed? #f) + (update)) + + (define/private (navigate-skip-to) + '...) + (define/private (insert-step-separator text) (send sbview add-text "\n ") (send sbview add-text @@ -296,6 +364,64 @@ (send text get-visible-position-range start-box end-box) (update) (send text scroll-to-position (unbox start-box) #f (unbox end-box))) + + (define (update:show-prefix) + ;; Show the final terms from the cached synth'd derivs + (for-each (lambda (d+sd) + (let ([e2 (lift/deriv-e2 (cdr d+sd))]) + (if e2 + (send sbview add-syntax e2) + (send sbview add-text "Error\n")))) + (reverse derivs-prefix))) + + (define (update:show-current-step) + (when steps + (let ([step (cursor:current steps)]) + (cond [(step? step) + (update:show-step step)] + [(misstep? step) + (update:show-misstep step)] + [(not step) + (update:show-final)])))) + + (define (update:show-step step) + (unless zoomed? + (when (pair? (step-lctx step)) + (for-each (lambda (bc) + (send sbview add-text "While executing macro transformer in:\n") + (insert-syntax/redex (cdr bc) (car bc))) + (step-lctx step)) + (send sbview add-text "\n")) + (insert-syntax/redex (step-e1 step) (foci (step-redex step))) + (insert-step-separator (step-note step)) + (insert-syntax/contractum (step-e2 step) (foci (step-contractum step)))) + (when zoomed? + (for-each (lambda (s) (insert-syntax s)) (foci (step-redex step))) + (insert-step-separator (step-note step)) + (for-each (lambda (s) (insert-syntax s)) (foci (step-contractum step))))) + + (define (update:show-misstep step) + (insert-syntax/redex (misstep-e1 step) (foci (misstep-redex step))) + (insert-step-separator "Error") + (send sbview add-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)) + (exn:fail:syntax-exprs (misstep-exn step))))) + + (define (update:show-final) + (let ([result (lift/deriv-e2 synth-deriv)]) + (when result + (send sbview add-text "Expansion finished\n") + (send sbview add-syntax result)) + (unless result + (send sbview add-text "Error\n")))) + + (define (update:show-suffix) + (when (pair? derivs) + (for-each (lambda (suffix-deriv) + (send sbview add-syntax (lift/deriv-e1 suffix-deriv))) + (cdr derivs)))) ;; update : -> void ;; Updates the terms in the syntax browser to the current step @@ -304,48 +430,13 @@ (define position-of-interest 0) (send text begin-edit-sequence) (send sbview erase-all) - (when (pair? derivs-prefix) - ;; Show the final terms from the cached synth'd derivs - (for-each (lambda (d+sd) - (let ([e2 (lift/deriv-e2 (cdr d+sd))]) - (if e2 - (send sbview add-syntax e2) - (send sbview add-text "Error\n")))) - (reverse derivs-prefix)) - (send sbview add-separator)) + + (unless zoomed? (update:show-prefix)) + (send sbview add-separator) (set! position-of-interest (send text last-position)) - (when steps - (let ([step (cursor:current steps)]) - (unless step - (let ([result (lift/deriv-e2 synth-deriv)]) - (when result - (send sbview add-text "Expansion finished\n") - (send sbview add-syntax result)) - (unless result - (send sbview add-text "Error\n")))) - (when (step? step) - (when (pair? (step-lctx step)) - (for-each (lambda (bc) - (send sbview add-text "While executing macro transformer in:\n") - (insert-syntax/redex (cdr bc) (car bc))) - (step-lctx step)) - (send sbview add-text "\n")) - (insert-syntax/redex (step-e1 step) (foci (step-redex step))) - (insert-step-separator (step-note step)) - (insert-syntax/contractum (step-e2 step) (foci (step-contractum step)))) - (when (misstep? step) - (insert-syntax/redex (misstep-e1 step) (foci (misstep-redex step))) - (insert-step-separator "Error") - (send sbview add-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)) - (exn:fail:syntax-exprs (misstep-exn step))))))) - (when (and (pair? derivs) (pair? (cdr derivs))) - (send sbview add-separator) - (for-each (lambda (suffix-deriv) - (send sbview add-syntax (lift/deriv-e1 suffix-deriv))) - (cdr derivs))) + (update:show-current-step) + (send sbview add-separator) + (update:show-suffix) (send text end-edit-sequence) (send text scroll-to-position position-of-interest @@ -354,14 +445,22 @@ 'start) (enable/disable-buttons)) + ;; insert-syntax : syntax -> void + (define/private (insert-syntax stx) + (send sbview add-syntax stx)) + ;; insert-syntax/redex : syntax syntaxes -> void (define/private (insert-syntax/redex stx foci) - (send sbview add-syntax stx foci "MistyRose")) - - ; insert-syntax/contractum : syntax syntaxes -> void + (if (send config get-highlight-foci?) + (send sbview add-syntax stx foci "MistyRose") + (send sbview add-syntax stx))) + + ;; insert-syntax/contractum : syntax syntaxes -> void (define/private (insert-syntax/contractum stx foci) - (send sbview add-syntax stx foci "LightCyan")) - + (if (send config get-highlight-foci?) + (send sbview add-syntax stx foci "LightCyan") + (send sbview add-syntax stx))) + ;; enable/disable-buttons : -> void (define/private (enable/disable-buttons) (send nav:start enable (and steps (cursor:can-move-previous? steps))) @@ -370,9 +469,17 @@ (send nav:end enable (and steps (cursor:can-move-next? steps))) (send nav:up enable (and (pair? derivs-prefix))) (send nav:down enable - (and (pair? derivs)))) + (and (pair? derivs))) + #; + (send nav:zoom-in enable + (and (not zoomed?) steps (step? (cursor:current steps)))) + #; + (send nav:zoom-out enable zoomed?) + #; + (send nav:jump-to enable #f)) + ;; -- - + ;; refresh/resynth : -> void ;; Resynth all of the derivations in prefix and refresh (define/public (refresh/resynth) @@ -411,28 +518,25 @@ (let ([show-macro? (get-show-macro?)]) (if show-macro? (with-handlers ([(lambda (e) (catch-errors?)) - (lambda (e) (no-synthesize deriv))]) + (lambda (e) (disable-hiding) deriv)]) (parameterize ((current-hiding-warning-handler (lambda (tag message) - (unless warnings-frame - (set! warnings-frame (new warnings-frame%))) - (send warnings-frame add-warning tag) - #; - (send warnings-frame add-text - (format "Warning: ~a~n" message))))) + (unless (send config get-suppress-warnings?) + (unless warnings-frame + (set! warnings-frame (new warnings-frame%))) + (send warnings-frame add-warning tag))))) (let-values ([(d s) (hide/policy deriv show-macro?)]) d))) deriv))) - (define/private (no-synthesize deriv) + (define/private (disable-hiding) (message-box "Macro Debugger" (string-append "This expansion triggers an error in the macro hiding code. " "Trying again with macro hiding disabled.")) - (send macro-hiding-prefs enable-hiding #f) - (synthesize deriv)) - + (queue-callback (lambda () (send config set-macro-hiding? #f)))) + ;; reduce : Derivation -> ReductionSequence (define/private (reduce d) (with-handlers ([(lambda (e) (catch-errors?)) @@ -442,31 +546,22 @@ "Internal error in macro stepper (reductions)") (set! synth-deriv #f) (set! steps #f))]) - (if (show-rename-steps?) + (if (send config get-show-rename-steps?) (reductions d) (filter (lambda (x) (not (rename-step? x))) (reductions d))))) - + (define/private (foci x) (if (list? x) x (list x))) ;; Hiding policy - (define/private (get-policy) - (and (send macro-hiding-prefs get-enabled?) - (send macro-hiding-prefs get-policy))) - (define/private (get-show-macro?) - (let ([policy (get-policy)]) - (and policy (lambda (id) (policy-show-macro? policy id))))) + (and (send config get-macro-hiding?) + (send macro-hiding-prefs get-show-macro?))) ;; -- (define/public (shutdown) - (let ([policy (get-policy)]) - (pref:macro-hiding? (and policy #t)) - (pref:hide-primitives? (and policy (hiding-policy-opaque-kernel policy))) - (pref:hide-libs? (and policy (hiding-policy-opaque-libs policy)))) - (pref:show-hiding-panel? (send control-pane is-shown?)) (when warnings-frame (send warnings-frame show #f))) ;; Initialization @@ -476,18 +571,10 @@ ;; Main entry points - (define make-macro-stepper - (case-lambda - [(policy hiding?) - (let ([f (new macro-stepper-frame% - (policy policy) - (macro-hiding? hiding?))]) - (send f show #t) - (send f get-widget))] - [(policy) - (make-macro-stepper policy #t)] - [() - (make-macro-stepper (new-hiding-policy) #f)])) + (define (make-macro-stepper) + (let ([f (new macro-stepper-frame%)]) + (send f show #t) + (send f get-widget))) (define (go stx) (let ([stepper (make-macro-stepper)]) @@ -499,8 +586,37 @@ (send w add-deriv deriv) (send f show #t) w)) + )) + ;; Extensions + + (define keymap-extension@ + (unit/sig sb:keymap^ + (import (pre : sb:keymap^)) + + (define syntax-keymap% + (class pre:syntax-keymap% + (init-field macro-stepper) + (inherit-field controller) + (inherit add-function) + + (super-new) + + (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)))))))) (define context-menu-extension@ (unit/sig sb:context-menu^ @@ -508,55 +624,35 @@ (define context-menu% (class pre:context-menu% - (init-field macro-stepper) - (inherit-field controller) + (inherit-field keymap) (inherit add-separator) - (define/private (get-prefs-panel) - (send macro-stepper get-macro-hiding-prefs)) - - (define show-macro #f) - (define hide-macro #f) - (define remove-macro #f) + (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 _ (do-show))))) + (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 _ (do-hide))))) - #;(set! remove-macro - (new menu-item% (label "Remove macro from policy") (parent this) - (callback (lambda _ (do-remove))))) + (callback (lambda (i e) + (send keymap call-function "hiding:hide-macro" i e))))) (void)) - (define/private (do-show) - (send* (get-prefs-panel) - (add-show-identifier) - (refresh))) - - (define/private (do-hide) - (send* (get-prefs-panel) - (add-hide-identifier) - (refresh))) - (define/override (on-demand) - (define-values (opaque transparent) - (let ([policy (send (get-prefs-panel) get-policy)]) - (values (hiding-policy-opaque-ids policy) - (hiding-policy-transparent-ids policy)))) + (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)) - (define transparent? - (and id? (module-identifier-mapping-get transparent stx (lambda () #f)))) - (define opaque? - (and id? (module-identifier-mapping-get opaque stx (lambda () #f)))) + (define show-macro? (send hiding-panel get-show-macro?)) + (define transparent? (and id? (show-macro? stx))) + (define opaque? (and id? (not (show-macro? stx)))) (send show-macro enable (and id? (not transparent?))) (send hide-macro enable (and id? (not opaque?))) - #;(send remove-macro enable (and id? (or opaque? transparent?))) (super on-demand)) (super-new))))) @@ -564,31 +660,53 @@ (define browser-extension@ (unit/sig sb:widget^ (import (pre : sb:widget^) - sb:context-menu^) + sb:keymap^) (define syntax-widget% (class pre:syntax-widget% (init-field macro-stepper) - (define/override (make-context-menu) - (new context-menu% + (define/override (make-keymap text) + (new syntax-keymap% + (editor text) (widget this) (macro-stepper macro-stepper))) (super-new))))) + ;; Linking + + (define context-menu@ + (compound-unit/sig + (import) + (link [SB:MENU : sb:context-menu^ (sb:widget-context-menu@)] + [V:MENU : sb:context-menu^ (context-menu-extension@ SB:MENU)]) + (export (open V:MENU)))) + + (define keymap@ + (compound-unit/sig + (import [MENU : sb:context-menu^] + [SNIP : sb:snip^]) + (link [SB:KEYMAP : sb:keymap^ (sb:widget-keymap@ MENU SNIP)] + [V:KEYMAP : sb:keymap^ (keymap-extension@ SB:KEYMAP)]) + (export (open V:KEYMAP)))) + + (define widget@ + (compound-unit/sig + (import [KEYMAP : sb:keymap^] + [MENU : sb:context-menu^]) + (link [SB:WIDGET : sb:widget^ (sb:widget@ KEYMAP)] + [V:WIDGET : sb:widget^ (browser-extension@ SB:WIDGET KEYMAP)]) + (export (open V:WIDGET)))) + (define pre-stepper@ (compound-unit/sig (import [BASE : view-base^]) (link [PREFS : prefs^ (prefs@)] - [SBKEYMAP : sb:keymap^ (sb:keymap@)] - [SBMENU : sb:context-menu^ (sb:context-menu@ SBSNIP)] - [SBSNIP : sb:snip^ (sb:global-snip@)] - [SBWMENU : sb:context-menu^ (sb:widget-context-menu-extension@ SBMENU)] - [VMENU : sb:context-menu^ (context-menu-extension@ SBWMENU)] - [SBWIDGET : sb:widget^ (sb:widget@ SBKEYMAP SBWMENU)] - [VWIDGET : sb:widget^ (browser-extension@ SBWIDGET VMENU)] - [VIEW : view^ (view@ PREFS BASE VWIDGET)]) + [MENU : sb:context-menu^ (context-menu@)] + [KEYMAP : sb:keymap^ (keymap@ MENU SNIP)] + [SNIP : sb:snip^ (sb:global-snip@)] + [WIDGET : sb:widget^ (widget@ KEYMAP MENU)] + [VIEW : view^ (view@ PREFS BASE WIDGET)]) (export (open VIEW)))) - ) diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index 1d22e752ee..146154ad22 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -4,6 +4,7 @@ (lib "mred.ss" "mred") (lib "list.ss") (lib "boundmap.ss" "syntax") + "util.ss" "../model/hiding-policies.ss" "../syntax-browser/util.ss") (provide macro-hiding-prefs-widget%) @@ -13,13 +14,24 @@ (class object% (init parent) (init-field stepper) - (init-field policy) - (init-field (enabled? #f)) - + (init-field config) + + (define policy (new-hiding-policy)) + (set-hiding-policy-opaque-kernel! policy (send config get-hide-primitives?)) + (set-hiding-policy-opaque-libs! policy (send config get-hide-libs?)) + (send config listen-hide-primitives? + (lambda (value) + (set-hiding-policy-opaque-kernel! policy value) + (refresh))) + (send config listen-hide-libs? + (lambda (value) + (set-hiding-policy-opaque-libs! policy value) + (refresh))) + (define stx #f) (define stx-name #f) (define stx-module #f) - + (define super-pane (new horizontal-pane% (parent parent) @@ -32,38 +44,24 @@ (define right-pane (new vertical-pane% (parent super-pane))) - + (define enable-ctl - (new check-box% - (label "Enable macro hiding?") - (parent left-pane) - (value enabled?) - (callback - (lambda _ - (set! enabled? (send enable-ctl get-value)) - (force-refresh))))) - + (check-box/notify-box left-pane + "Enable macro hiding?" + (get-field macro-hiding? config))) + (send config listen-macro-hiding? + (lambda (value) (force-refresh))) + (define kernel-ctl - (new check-box% - (label "Hide mzscheme syntax") - (parent left-pane) - (value (hiding-policy-opaque-kernel policy)) - (callback (lambda _ - (if (send kernel-ctl get-value) - (policy-hide-kernel policy) - (policy-unhide-kernel policy)) - (refresh))))) + (check-box/notify-box left-pane + "Hide mzscheme syntax" + (get-field hide-primitives? config))) + (define libs-ctl - (new check-box% - (label "Hide library syntax") - (parent left-pane) - (value (hiding-policy-opaque-libs policy)) - (callback (lambda _ - (if (send libs-ctl get-value) - (policy-hide-libs policy) - (policy-unhide-libs policy)) - (refresh))))) - + (check-box/notify-box left-pane + "Hide library syntax" + (get-field hide-libs? config))) + (define look-pane (new horizontal-pane% (parent right-pane) (stretchable-height #f))) (define look-ctl @@ -97,23 +95,14 @@ ;; Methods - ;; enable-hiding : boolean -> void - ;; Called only by stepper, which does it's own refresh - (define/public (enable-hiding ok?) - (send enable-ctl set-value ok?) - (set! enabled? ok?)) - - ;; get-enabled? - (define/public (get-enabled?) enabled?) - - ;; get-policy - (define/public (get-policy) policy) + (define/public (get-show-macro?) + (lambda (id) (policy-show-macro? policy id))) ;; refresh (define/public (refresh) - (when enabled? + (when (send config get-macro-hiding?) (send stepper refresh/resynth))) - + ;; force-refresh (define/private (force-refresh) (send stepper refresh/resynth)) @@ -221,4 +210,4 @@ (super-new))) - ) \ No newline at end of file + ) diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss index d68591b2f3..515941126a 100644 --- a/collects/macro-debugger/view/interfaces.ss +++ b/collects/macro-debugger/view/interfaces.ss @@ -20,9 +20,26 @@ pref:height pref:props-percentage pref:macro-hiding? + pref:show-syntax-properties? pref:show-hiding-panel? pref:hide-primitives? pref:hide-libs? - pref:identifier=?)) + pref:identifier=? + pref:show-rename-steps? + pref:highlight-foci? + pref:suppress-warnings? + )) + + ;; 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 5f9574269c..4d0e2dd790 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -21,18 +21,27 @@ (preferences:set-default 'MacroStepper:Frame:Height 600 number?) (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) (preferences:set-default 'MacroStepper:MacroHiding? #t boolean?) + (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) (preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?) (preferences:set-default 'MacroStepper:HideLibs? #t boolean?) (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) + (preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?) + (preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?) + (preferences:set-default 'MacroStepper:SuppressWarnings? #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? MacroStepper:MacroHiding?) + (pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?) (pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?) (pref:get/set pref:hide-primitives? MacroStepper:HidePrimitives?) (pref:get/set pref:hide-libs? MacroStepper:HideLibs?) (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison) + (pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?) + (pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?) + (pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?) + )) ) diff --git a/collects/macro-debugger/view/util.ss b/collects/macro-debugger/view/util.ss index 17e62eacad..df2cb57b67 100644 --- a/collects/macro-debugger/view/util.ss +++ b/collects/macro-debugger/view/util.ss @@ -1,11 +1,135 @@ (module util mzscheme - (require (lib "class.ss")) - (provide override/return-false) + (require (lib "class.ss") + (lib "mred.ss" "mred")) + (provide define/listen + field/notify + override/return-false + notify-box% + notify-box/pref + menu-option/notify-box + menu-group/notify-box + check-box/notify-box) + + (define notification-lock (make-parameter #f)) + + (define-for-syntax (join . args) + (define (->string x) + (cond [(string? x) x] + [(symbol? x) (symbol->string)] + [(identifier? x) (symbol->string (syntax-e x))] + [else (error '->string)])) + (string->symbol (apply string-append (map ->string args)))) (define-syntax override/return-false (syntax-rules () [(override/return-false m ...) (begin (define/override (m) #f) ...)])) - - ) \ No newline at end of file + + (define-syntax (field/notify stx) + (syntax-case stx () + [(field/notify name value) + (with-syntax ([get-name + (datum->syntax-object #'name (join "get-" #'name))] + [set-name + (datum->syntax-object #'name (join "set-" #'name))] + [listen-name + (datum->syntax-object #'name (join "listen-" #'name))]) + #'(begin (field [name value]) + (define/public (get-name) + (send name get)) + (define/public (set-name new-value) + (send name set new-value)) + (define/public (listen-name listener) + (send name listen listener))))])) + + (define-syntax (define/listen stx) + (syntax-case stx () + [(define/listen name value) + (unless (identifier? #'name) + (raise-syntax-error 'define/listen "expected identifier" #'name)) + (with-syntax ([get-name + (datum->syntax-object #'name (join "get-" #'name))] + [set-name + (datum->syntax-object #'name (join "set-" #'name))] + [listen-name + (datum->syntax-object #'name (join "listen-" #'name))]) + #'(begin + (define name value) + (define listeners null) + (define/public (get-name) name) + (define/public (set-name new-value) + (set! name new-value) + (for-each (lambda (listener) (listener new-value)) listeners)) + (define/public (listen-name listener) + (set! listeners (cons listener listeners)))))])) + + (define notify-box% + (class object% + (init value) + (define v value) + (define listeners null) + + ;; get : -> value + ;; Fetch current value + (define/public (get) + v) + + ;; set : value -> void + ;; Update value and notify listeners + (define/public (set nv) + (when (notification-lock) + (error 'notify-box%::set "nested mutation")) + (set! v nv) + (parameterize ((notification-lock #t)) + (for-each (lambda (p) (p nv)) listeners))) + + ;; listen : (value -> void) -> void + ;; Add a listener + (define/public (listen p) + (set! listeners (cons p listeners))) + + (super-new))) + + (define (notify-box/pref pref) + (define nb (new notify-box% (value (pref)))) + (send nb listen pref) + nb) + + (define (menu-option/notify-box parent label nb) + (define menu-item + (new checkable-menu-item% + (label label) + (parent parent) + (checked (send nb get)) + (callback + (lambda _ (send nb set (not (send nb get))))))) + (send nb listen (lambda (value) (send menu-item check value))) + menu-item) + + (define (check-box/notify-box parent label nb) + (define checkbox + (new check-box% + (label label) + (parent parent) + (value (send nb get)) + (callback + (lambda (c e) (send nb set (send c get-value)))))) + (send nb listen (lambda (value) (send checkbox set-value value))) + checkbox) + + (define (menu-group/notify-box parent labels nb) + (map (lambda (option) + (define label (if (pair? option) (car option) option)) + (define menu-item + (new checkable-menu-item% + (label label) + (parent parent) + (checked (eq? (send nb get) option)) + (callback + (lambda _ (send nb set option))))) + (send nb listen + (lambda (value) (send menu-item check (eq? value option)))) + menu-item) + labels)) + ) diff --git a/collects/macro-debugger/view/warning.ss b/collects/macro-debugger/view/warning.ss index 3e2ba9f72f..f34b677a88 100644 --- a/collects/macro-debugger/view/warning.ss +++ b/collects/macro-debugger/view/warning.ss @@ -1,22 +1,23 @@ (module warning mzscheme (require (lib "class.ss") - (lib "mred.ss" "mred")) + (lib "mred.ss" "mred") + (lib "framework.ss" "framework")) (provide warnings-frame%) - + ;; warnings-frame% (define warnings-frame% (class frame% (super-new (label "Macro stepper warnings") (width 400) (height 300)) - - (define text (new text% (auto-wrap #t))) + + (define text (new text:hide-caret/selection% (auto-wrap #t))) (define ec (new editor-canvas% (parent this) (editor text))) (send text lock #t) - + (define -nonlinearity-text #f) (define -localactions-text #f) (define -lifts-text #f) - + (define/private (add-nonlinearity-text) (unless -nonlinearity-text (set! -nonlinearity-text #t)