(module gui 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" "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 pre-stepper@ view@ context-menu-extension@ browser-extension@) ;; Struct for one-by-one stepping (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))) ;; TermRecords (define-struct trec (deriv synth-deriv estx raw-steps steps definites) #f) (define (new-trec deriv) (make-trec deriv #f #f #f #f #f)) ;; trec:invalidate-synth! : TermRecord -> void ;; Invalidates cached parts that depend on macro-hiding policy (define (trec:invalidate-synth! trec) (set-trec-synth-deriv! trec #f) (set-trec-estx! trec #f) (set-trec-raw-steps! trec #f) (set-trec-definites! trec #f) (trec:invalidate-steps! trec)) ;; trec:invalidate-steps! : TermRecord -> void ;; Invalidates cached parts that depend on reductions config (define (trec:invalidate-steps! trec) (set-trec-steps! trec #f)) ;; Macro Stepper (define view@ (unit (import prefs^ view-base^ (prefix sb: sb:widget^)) (export view^) (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 highlight-frontier? (notify-box/pref pref:highlight-frontier?)) (field/notify show-rename-steps? (notify-box/pref pref:show-rename-steps?)) (field/notify suppress-warnings? (notify-box/pref pref:suppress-warnings?)) (field/notify one-by-one? (notify-box/pref pref:one-by-one?)) (field/notify extra-navigation? (notify-box/pref pref:extra-navigation?)) (field/notify debug-catch-errors? (notify-box/pref pref:debug-catch-errors?)) (field/notify force-letrec-transformation? (notify-box/pref pref:force-letrec-transformation?)) (super-new))) (define macro-stepper-frame% (class base-frame% (init-field (filename #f)) (init (identifier=? (pref:identifier=?))) (init-field (config (new macro-stepper-config%))) (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) (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/override (on-size w h) (send config set-width w) (send config set-height h) (send widget update/preserve-view)) (define/augment (on-close) (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? 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 warning-panel (new horizontal-panel% (parent (get-area-container)) (stretchable-height #f) (style '(deleted)))) (define widget (new macro-stepper-widget% (parent (get-area-container)) (config config))) (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)))))) ;; 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)))))]) (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))) (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)) (new (get-menu-item%) (label "Show in new frame") (parent stepper-menu) (callback (lambda _ (send widget show-in-new-frame)))) (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) )) ;; macro-stepper-widget% (define macro-stepper-widget% (class* object% () (init-field parent) (init-field config) ;; Terms ;; terms : (Cursor-of TermRecord) (define terms (cursor:new null)) ;; focused-term : -> TermRecord or #f (define (focused-term) (let ([term (cursor:next terms)]) (when term (recache term)) term)) ;; focused-steps : -> (Cursor-of Step) or #f (define/private (focused-steps) (let ([term (focused-term)]) (and term (cursor? (trec-steps term)) (trec-steps term)))) ;; alpha-table : module-identifier-mapping[identifier => identifier] (define alpha-table (make-module-identifier-mapping)) ;; saved-position : number/#f (define saved-position #f) ;; add-deriv : Derivation -> void (define/public (add-deriv d) (let ([needs-display? (cursor:at-end? terms)]) (for-each (lambda (id) (module-identifier-mapping-put! alpha-table id id)) (extract-all-fresh-names d)) (cursor:add-to-end! terms (list (new-trec d))) (trim-navigator) (if needs-display? (refresh/move) (update)))) (define/public (get-controller) sbc) (define/public (get-view) sbview) (define/public (get-macro-hiding-prefs) macro-hiding-prefs) (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 sbview (new sb:syntax-widget% (parent area) (macro-stepper this) (pref:props-percentage pref:props-percentage))) (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))) (define warnings-frame #f) (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 add-selection-listener (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/public (show-in-new-frame) (when (cursor:next terms) (go/deriv (trec-deriv (cursor:next terms))))) (define/private (show-extra-navigation show?) (send supernavigator change-children (lambda (children) (if show? (list navigator extra-navigator) (list navigator))))) ;; Navigate (define/private (navigate-to-start) (cursor:move-to-start (focused-steps)) (update/save-position)) (define/private (navigate-to-end) (cursor:move-to-end (focused-steps)) (update/save-position)) (define/private (navigate-previous) (cursor:move-prev (focused-steps)) (update/save-position)) (define/private (navigate-next) (cursor:move-next (focused-steps)) (update/save-position)) (define/private (navigate-up) (cursor:move-prev terms) (refresh/move)) (define/private (navigate-down) (cursor:move-next terms) (refresh/move)) ;; 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/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")) ;; 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))) ;; update:show-prefix : -> void (define/private (update:show-prefix) ;; Show the final terms from the cached synth'd derivs (for-each (lambda (trec) (recache trec) (let ([e2 (trec-estx trec)] [definites (if (pair? (trec-definites trec)) (trec-definites trec) null)]) (if e2 (send sbview add-syntax e2 #:alpha-table alpha-table #:definites definites) (send sbview add-text "Error\n")))) (cursor:prefix->list terms))) ;; update:show-current-step : -> void (define/private (update:show-current-step) (define steps (focused-steps)) (when (focused-term) (when steps (let ([step (cursor:next steps)]) (cond [(step? step) (update:show-step step)] [(misstep? step) (update:show-misstep step)] [(prestep? step) (update:show-prestep step)] [(poststep? step) (update:show-poststep step)] [(not step) (update:show-final (focused-term))]))) (unless steps (send sbview add-text "Internal error computing reductions. Original term:\n") (send sbview add-syntax (lift/deriv-e1 (trec-deriv (focused-term)))) #;(print-struct #t) #;(send sbview add-text (format "~s~n" (focused-term)))))) ;; update:show-lctx : Step -> void (define/private (update:show-lctx step) (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) (protostep-definites step) (protostep-frontier step))) (reverse lctx)))) ;; update:separator : Step -> void (define/private (update:separator step) (insert-step-separator (step-type->string (protostep-type step)))) ;; update:separator/small : Step -> void (define/private (update:separator/small step) (insert-step-separator/small (step-type->string (protostep-type step)))) ;; update:show-step : Step -> void (define/private (update:show-step step) (insert-syntax/redex (step-term1 step) (step-foci1 step) (protostep-definites step) (protostep-frontier step)) (update:separator step) (insert-syntax/contractum (step-term2 step) (step-foci2 step) (protostep-definites step) (protostep-frontier step)) (update:show-lctx step)) ;; update:show-prestep : Step -> void (define/private (update:show-prestep step) (update:separator/small step) (insert-syntax/redex (prestep-term1 step) (prestep-foci1 step) (protostep-definites step) (protostep-frontier step)) (update:show-lctx step)) ;; update:show-poststep : Step -> void (define/private (update:show-poststep step) (update:separator/small step) (insert-syntax/contractum (poststep-term2 step) (poststep-foci2 step) (protostep-definites step) (protostep-frontier step)) (update:show-lctx step)) ;; update:show-misstep : Step -> void (define/private (update:show-misstep step) (insert-syntax/redex (misstep-term1 step) (misstep-foci1 step) (protostep-definites step) (protostep-frontier step)) (update:separator step) (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 #:alpha-table alpha-table #:definites (protostep-definites step))) (exn:fail:syntax-exprs (misstep-exn step)))) (update:show-lctx step)) ;; update:show-final : TermRecord -> void (define/private (update:show-final trec) (define result (trec-estx trec)) (when result (send sbview add-text "Expansion finished\n") (send sbview add-syntax result #:alpha-table alpha-table #:definites (let ([definites (trec-definites trec)]) (if (pair? definites) definites null)))) (unless result (send sbview add-text "Error\n"))) ;; update:show-suffix : -> void (define/private (update:show-suffix) (let ([suffix0 (cursor:suffix->list terms)]) (when (pair? suffix0) (for-each (lambda (trec) (send sbview add-syntax (lift/deriv-e1 (trec-deriv trec)) #:alpha-table alpha-table)) (cdr suffix0))))) ;; update/save-position : -> void (define/private (update/save-position) (save-position) (update)) ;; 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) (send text begin-edit-sequence) (send sbview erase-all) (update:show-prefix) (send sbview add-separator) (set! position-of-interest (send text last-position)) (update:show-current-step) (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)) ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void (define/private (insert-syntax/color stx foci definites frontier hi-color) (send sbview add-syntax stx #:definites definites #:alpha-table alpha-table #: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 definites frontier) (insert-syntax/color stx foci definites frontier "MistyRose")) ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void (define/private (insert-syntax/contractum stx foci definites frontier) (insert-syntax/color stx foci definites frontier "LightCyan")) ;; enable/disable-buttons : -> void (define/private (enable/disable-buttons) (define steps (focused-steps)) (send nav:start enable (and steps (cursor:has-prev? steps))) (send nav:previous enable (and steps (cursor:has-prev? steps))) (send nav:next enable (and steps (cursor:has-next? steps))) (send nav:end enable (and steps (cursor:has-next? steps))) (send nav:up enable (cursor:has-prev? terms)) (send nav:down enable (cursor:has-next? terms))) ;; -- ;; refresh/resynth : -> void ;; Macro hiding policy has changed; invalidate cached parts of trec (define/public (refresh/resynth) (for-each trec:invalidate-synth! (cursor->list terms)) (refresh)) ;; refresh/re-reduce : -> void ;; Reduction config has changed; invalidate cached parts of trec (define/private (refresh/re-reduce) (for-each trec:invalidate-steps! (cursor->list terms)) (refresh)) ;; refresh/move : -> void ;; Moving between terms; clear the saved position (define/private (refresh/move) (clear-saved-position) (refresh)) ;; refresh : -> void (define/public (refresh) (restore-position) (update)) ;; recache : TermRecord -> void (define/private (recache trec) (unless (trec-synth-deriv trec) (with-handlers ([(lambda (e) #t) (lambda (e) (handle-recache-error e 'macro-hiding) (set-trec-synth-deriv! trec 'error) (set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))]) (let-values ([(synth-deriv estx) (synthesize (trec-deriv trec))]) (set-trec-synth-deriv! trec synth-deriv) (set-trec-estx! trec estx)))) (unless (trec-raw-steps trec) (with-handlers ([(lambda (e) #t) (lambda (e) (handle-recache-error e 'reductions) (set-trec-raw-steps! trec 'error) (set-trec-definites! trec 'error))]) (let-values ([(steps definites) (reductions+definites (or (trec-synth-deriv trec) (trec-deriv trec)))]) (set-trec-raw-steps! trec steps) (set-trec-definites! trec definites)))) (unless (trec-steps trec) (with-handlers ([(lambda (e) #t) (lambda (e) (handle-recache-error e 'special-reductions) (set-trec-steps! trec 'error))]) (set-trec-steps! trec (let ([raw-steps (trec-raw-steps trec)]) (if (eq? raw-steps 'error) 'error (let ([filtered-steps (if (send config get-show-rename-steps?) raw-steps (filter (lambda (x) (not (rename-step? x))) raw-steps))]) (cursor:new (if (send config get-one-by-one?) (reduce:one-by-one filtered-steps) filtered-steps))))))))) ;; 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 (pref: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-saved-position : num -> void (define/private (update-saved-position pos) (when pos (set! saved-position pos))) ;; clear-saved-position : -> void (define/private (clear-saved-position) (set! saved-position #f)) ;; save-position : -> void (define/private (save-position) (when (cursor? (focused-steps)) (let ([step (cursor:next (focused-steps))]) (cond [(not step) ;; At end; go to the end when restored (update-saved-position +inf.0)] [(protostep? step) (update-saved-position (extract-protostep-seq step))])))) ;; restore-position : number -> void (define/private (restore-position) (define steps (focused-steps)) (define (advance) (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) (advance)] [(< step-pos saved-position) (cursor:move-next steps) (advance)] [else (void)]))]))) (when saved-position (when steps (advance)))) (define/private (extract-protostep-seq step) (match (protostep-deriv step) [(AnyQ mrule (_ _ (AnyQ transformation (_ _ _ _ _ _ seq)) _)) seq] [else #f])) ;; synthesize : Derivation -> Derivation Syntax (define/private (synthesize deriv) (let ([show-macro? (get-show-macro?)]) (if show-macro? (parameterize ((current-hiding-warning-handler (lambda (tag message) (unless (send config get-suppress-warnings?) (unless warnings-frame (set! warnings-frame (new warnings-frame%))) (send warnings-frame add-warning tag message) (send warnings-frame show #t)))) (force-letrec-transformation (send config get-force-letrec-transformation?))) (hide/policy deriv show-macro?)) (values deriv (lift/deriv-e2 deriv))))) (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]))) (define/private (foci x) (if (list? x) x (list x))) ;; Hiding policy (define/private (get-show-macro?) (and (send config get-macro-hiding?) (send macro-hiding-prefs get-show-macro?))) ;; -- (define/public (shutdown) (when warnings-frame (send warnings-frame show #f))) ;; 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) )) ;; Main entry points (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)]) (send stepper add-deriv (trace stx)))) (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)) )) ;; Extensions (define keymap-extension@ (unit (import (prefix pre: sb:keymap^)) (export 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 (import (prefix pre: sb:context-menu^)) (export sb:context-menu^) (define context-menu% (class pre: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)) (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?))) (super on-demand)) (super-new))))) (define browser-extension@ (unit (import (prefix pre: sb:widget^) sb:keymap^) (export sb:widget^) (define syntax-widget% (class pre:syntax-widget% (init-field macro-stepper) (define/override (make-keymap text) (new syntax-keymap% (editor text) (widget this) (macro-stepper macro-stepper))) (define/override (show-props show?) (super show-props show?) (send macro-stepper update/preserve-view)) (super-new))))) ;; Linking (define context-menu@ (compound-unit (import) (link [((SB:MENU : sb:context-menu^)) sb:widget-context-menu@] [((V:MENU : sb:context-menu^)) context-menu-extension@ SB:MENU]) (export V:MENU))) (define keymap@ (compound-unit (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 V:KEYMAP))) (define widget@ (compound-unit (import [KEYMAP : sb:keymap^]) (link [((SB:WIDGET : sb:widget^)) sb:widget@ KEYMAP] [((V:WIDGET : sb:widget^)) browser-extension@ SB:WIDGET KEYMAP]) (export V:WIDGET))) (define pre-stepper@ (compound-unit (import [BASE : view-base^]) (link [((PREFS : prefs^)) prefs@] [((MENU : sb:context-menu^)) context-menu@] [((KEYMAP : sb:keymap^)) keymap@ MENU SNIP] [((SNIP : sb:snip^)) sb:global-snip@] [((WIDGET : sb:widget^)) widget@ KEYMAP] [((VIEW : view^)) view@ PREFS BASE WIDGET]) (export VIEW))) ;; Stolen from stepper (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))) )