commit 5929a60d3b754b446bc257c687487f9e80d49d12 parent b048acb9ef1eed587437a9e9522a8ada649e2321 Author: Matthew Flatt <mflatt@racket-lang.org> Date: Fri, 24 May 2013 21:57:31 -0600 reorganize into core plus packages The "racket" directory contains a pared-back version of the repository, roughly. The "pkgs" directory everything else in the repository, but organized into packages. original commit: b2ebb0a28bf8136e75cd98316c22fe54c30eacb2 Diffstat:
112 files changed, 4327 insertions(+), 4326 deletions(-)
diff --git a/collects/macro-debugger/info.rkt b/collects/macro-debugger/info.rkt @@ -1,16 +0,0 @@ -#lang setup/infotab - -(define drracket-tools '(["tool.rkt"])) -(define drracket-tool-names '("Macro Stepper")) -(define drracket-tool-icons (list '("macro-stepper-32x32.png" "icons"))) -(define scribblings '(("macro-debugger.scrbl" () (tool-library)))) - -(define raco-commands - '(("check-requires" - (submod macro-debugger/analysis/check-requires main) - "check for useless requires" - #f) - ("show-dependencies" - (submod macro-debugger/analysis/show-dependencies main) - "show module dependencies" - #f))) diff --git a/collects/macro-debugger/model/trace-raw.rkt b/collects/macro-debugger/model/trace-raw.rkt @@ -1,34 +0,0 @@ -#lang racket/base -(require racket/class - parser-tools/lex - "deriv-tokens.rkt" - "../syntax-browser/frame.rkt") -(provide (all-defined-out)) - -(define current-expand-observe - (dynamic-require ''#%expobs 'current-expand-observe)) - -(define (go-trace sexpr) - (define events null) - (define pos 0) - (define browser (make-syntax-browser)) - (define (show sig+val) - (define sig (car sig+val)) - (define val (cdr sig+val)) - (define t (tokenize sig val pos)) - (send browser add-text - (format "Signal: ~s: ~s\n" - pos - (token-name (position-token-token t)))) - (when val - (send browser add-syntax - (datum->syntax #f val))) - (set! pos (add1 pos))) - (parameterize ((current-expand-observe - (lambda (sig val) - (define t (tokenize sig val pos)) - (set! events (cons (cons sig val) events)) - #;(show (cons sig val))))) - (expand sexpr) - (for-each show (reverse events)))) - diff --git a/collects/macro-debugger/stepper.rkt b/collects/macro-debugger/stepper.rkt @@ -1,25 +0,0 @@ -#lang racket/base -(require racket/class - racket/contract/base - unstable/class-iop - "model/trace.rkt" - "view/interfaces.rkt" - "view/view.rkt") - -(define (create-stepper deriv) - (define director (new macro-stepper-director%)) - (define stepper (send/i director director<%> new-stepper)) - (send/i director director<%> add-deriv deriv) - (void)) - -(define (expand/step stx) - (create-stepper (trace stx))) - -(define (expand-module/step module-path) - (create-stepper (trace-module module-path))) - -(provide/contract - [expand/step - (-> syntax? void?)] - [expand-module/step - (-> module-path? void?)]) diff --git a/collects/macro-debugger/syntax-browser/controller.rkt b/collects/macro-debugger/syntax-browser/controller.rkt @@ -1,70 +0,0 @@ -#lang racket/base -(require racket/class - unstable/class-iop - "interfaces.rkt" - "partition.rkt" - unstable/gui/notify) -(provide controller%) - -;; displays-manager-mixin -(define displays-manager-mixin - (mixin () (displays-manager<%>) - ;; displays : (list-of display<%>) - (field [displays null]) - - ;; add-syntax-display : display<%> -> void - (define/public (add-syntax-display c) - (set! displays (cons c displays))) - - ;; remove-all-syntax-displays : -> void - (define/public (remove-all-syntax-displays) - (set! displays null)) - - (super-new))) - -;; selection-manager-mixin -(define selection-manager-mixin - (mixin (displays-manager<%>) (selection-manager<%>) - (inherit-field displays) - (define-notify selected-syntax (new notify-box% (value #f))) - - (super-new) - (listen-selected-syntax - (lambda (new-value) - (for-each (lambda (display) (send/i display display<%> refresh)) - displays))))) - -;; mark-manager-mixin -(define mark-manager-mixin - (mixin () (mark-manager<%>) - (init-field/i [primary-partition partition<%> (new-bound-partition)]) - (super-new) - - ;; get-primary-partition : -> partition - (define/public-final (get-primary-partition) - primary-partition) - - ;; reset-primary-partition : -> void - (define/public-final (reset-primary-partition) - (set! primary-partition (new-bound-partition))))) - -;; secondary-relation-mixin -(define secondary-relation-mixin - (mixin (displays-manager<%>) (secondary-relation<%>) - (inherit-field displays) - (define-notify identifier=? (new notify-box% (value #f))) - - (listen-identifier=? - (lambda (name+proc) - (for ([d (in-list displays)]) - (send/i d display<%> refresh)))) - (super-new))) - -(define controller% - (class* (secondary-relation-mixin - (selection-manager-mixin - (mark-manager-mixin - (displays-manager-mixin - object%)))) - (controller<%>) - (super-new))) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt @@ -1,418 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - racket/promise - data/interval-map - framework - unstable/class-iop - "pretty-printer.rkt" - "interfaces.rkt" - "prefs.rkt" - "util.rkt" - "../util/logger.rkt") -(provide print-syntax-to-editor - code-style) - -(define-syntax-rule (uninterruptible e ...) - ;; (coarsely) prevent breaks within editor operations - (parameterize-break #f (begin e ...)) - #| - (parameterize-break #f - (let ([ta (now)]) - (begin0 (begin e ...) - (let ([tb (now)]) - (eprintf "****\n") - (pretty-write '(begin e ...) (current-error-port)) - (eprintf " -- ~s ms\n\n" (- tb ta)))))) - |#) - -(define (now) (current-inexact-milliseconds)) - -;; FIXME: assumes text never moves - -;; print-syntax-to-editor : syntax text controller<%> config number number -;; -> display<%> -;; Note: must call display<%>::refresh to finish styling. -(define (print-syntax-to-editor stx text controller config columns - [insertion-point (send text last-position)]) - (define output-port (open-output-string/count-lines)) - (define range - (with-log-time "** pretty-print-syntax" - (pretty-print-syntax stx output-port - (send/i controller controller<%> get-primary-partition) - (length (send/i config config<%> get-colors)) - (send/i config config<%> get-suffix-option) - (send config get-pretty-styles) - columns - (send config get-pretty-abbrev?)))) - (define output-string (get-output-string output-port)) - (define output-length (sub1 (string-length output-string))) ;; skip final newline - (log-macro-stepper-debug "size of pretty-printed text: ~s" output-length) - (with-log-time "fixup-parentheses" - (fixup-parentheses output-string range)) - (with-unlock text - (with-log-time "inserting pretty-printed text" - (uninterruptible - (send text insert output-length output-string insertion-point))) - (new display% - (text text) - (controller controller) - (config config) - (range range) - (start-position insertion-point) - (end-position (+ insertion-point output-length))))) - -;; display% -;; Note: must call refresh method to finish styling. -(define display% - (class* object% (display<%>) - (init-field/i [controller controller<%>] - [config config<%>] - [range range<%>]) - (init-field text - start-position - end-position) - - (define base-style - (code-style text (send/i config config<%> get-syntax-font-size))) - - ;; on-next-refresh : (listof (cons stx style-delta)) - ;; Styles to be applied on next refresh only. (eg, underline) - (define on-next-refresh null) - - ;; extra-styles : hash[stx => (listof style-delta)] - ;; Styles to be re-applied on every refresh. - (define extra-styles (make-hasheq)) - - ;; to-undo-styles : (listof (cons nat nat)) - ;; Ranges to unbold or unhighlight when selection changes. - ;; FIXME: ought to be managed by text:region-data (to auto-update ranges) - ;; until then, positions are relative - (define to-undo-styles null) - - ;; initialize : -> void - (define/private (initialize) - (with-log-time "changing base style" - (uninterruptible - (send text change-style base-style start-position end-position #f))) - (with-log-time "applying primary styles" - (uninterruptible (apply-primary-partition-styles))) - (with-log-time "adding clickbacks" - (uninterruptible (add-clickbacks)))) - - ;; add-clickbacks : -> void - (define/private (add-clickbacks) - (define mapping (send text get-region-mapping 'syntax)) - (define lazy-interval-map-init - (delay - (with-log-time "forcing clickback mapping" - (uninterruptible - (for ([range (send/i range range<%> all-ranges)]) - (let ([stx (range-obj range)] - [start (range-start range)] - [end (range-end range)]) - (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))) - (define (the-callback position) - (force lazy-interval-map-init) - (send/i controller selection-manager<%> set-selected-syntax - (interval-map-ref mapping position #f))) - (send text set-clickregion start-position end-position the-callback) - (send text set-clickregion start-position end-position the-callback 'right-down)) - - ;; refresh : -> void - ;; Clears all highlighting and reapplies all non-foreground styles. - (define/public (refresh) - (with-log-time "refresh" - (with-unlock text - (uninterruptible - (let ([undo-select/highlight-d (get-undo-select/highlight-d)]) - (for ([r (in-list to-undo-styles)]) - (send text change-style undo-select/highlight-d - (relative->text-position (car r)) - (relative->text-position (cdr r))))) - (set! to-undo-styles null)) - (uninterruptible - (for ([stx+delta (in-list on-next-refresh)]) - (for ([r (in-list (send/i range range<%> get-ranges (car stx+delta)))]) - (restyle-range r (cdr stx+delta) #f))) - (set! on-next-refresh null)) - (uninterruptible - (apply-extra-styles)) - (let ([selected-syntax - (send/i controller selection-manager<%> - get-selected-syntax)]) - (uninterruptible - (apply-secondary-relation-styles selected-syntax)) - (uninterruptible - (apply-selection-styles selected-syntax)))))) - - ;; get-range : -> range<%> - (define/public (get-range) range) - - ;; get-start-position : -> number - (define/public (get-start-position) start-position) - - ;; get-end-position : -> number - (define/public (get-end-position) end-position) - - ;; highlight-syntaxes : (list-of syntax) string -> void - (define/public (highlight-syntaxes stxs hi-color) - (let ([delta (highlight-style-delta hi-color)]) - (for ([stx (in-list stxs)]) - (hash-set! extra-styles stx - (cons delta (hash-ref extra-styles stx null)))))) - - ;; underline-syntaxes : (listof syntax) -> void - (define/public (underline-syntaxes stxs) - (for ([stx (in-list stxs)]) - (set! on-next-refresh - (cons (cons stx underline-d) on-next-refresh)))) - - ;; Primary styles - ;; (Done once on initialization, never repeated) - - ;; apply-primary-partition-styles : -> void - ;; Changes the foreground color according to the primary partition. - ;; Only called once, when the syntax is first drawn. - (define/private (apply-primary-partition-styles) - (define style-list (send text get-style-list)) - (define (color-style color) - (let ([delta (new style-delta%)]) - (send delta set-delta-foreground color) - (send style-list find-or-create-style base-style delta))) - (define color-styles - (list->vector - (map color-style - (map translate-color - (send/i config config<%> get-colors))))) - (define overflow-style (color-style (translate-color "darkgray"))) - (define color-partition - (send/i controller mark-manager<%> get-primary-partition)) - (define offset start-position) - ;; Optimization: don't call change-style when new style = old style - (let tr*loop ([trs (send/i range range<%> get-treeranges)] [old-style #f]) - (for ([tr trs]) - (define stx (treerange-obj tr)) - (define start (treerange-start tr)) - (define end (treerange-end tr)) - (define subs (treerange-subs tr)) - (define new-style - (primary-style stx color-partition color-styles overflow-style)) - (unless (eq? old-style new-style) - (send text change-style new-style (+ offset start) (+ offset end) #f)) - (tr*loop subs new-style))) - (void)) - - ;; primary-style : syntax partition (vector-of style-delta%) style-delta% - ;; -> style-delta% - (define/private (primary-style stx partition color-vector overflow) - (let ([n (send/i partition partition<%> get-partition stx)]) - (cond [(< n (vector-length color-vector)) - (vector-ref color-vector n)] - [else - overflow]))) - - ;; Secondary Styling - ;; May change in response to user actions - - ;; apply-extra-styles : -> void - ;; Applies externally-added styles (such as highlighting) - (define/private (apply-extra-styles) - (for ([(stx deltas) (in-hash extra-styles)]) - (for ([r (in-list (send/i range range<%> get-ranges stx))]) - (for ([delta (in-list deltas)]) - (restyle-range r delta #t))))) - - ;; apply-selection-styles : syntax -> void - ;; Styles subterms eq to the selected syntax - (define/private (apply-selection-styles selected-syntax) - (for ([r (in-list (send/i range range<%> get-ranges selected-syntax))]) - (restyle-range r select-d #t))) - - ;; apply-secondary-relation-styles : selected-syntax -> void - ;; If the selected syntax is an identifier, then styles all identifiers - ;; in the relation with it. - (define/private (apply-secondary-relation-styles selected-syntax) - (when (identifier? selected-syntax) - (let* ([name+relation - (send/i controller secondary-relation<%> - get-identifier=?)] - [relation (and name+relation (cdr name+relation))] - [secondary-highlight-d (get-secondary-highlight-d)]) - (when relation - (for ([id (in-list (send/i range range<%> get-identifier-list))]) - (when (relation selected-syntax id) - (for ([r (in-list (send/i range range<%> get-ranges id))]) - (restyle-range r secondary-highlight-d #t)))))))) - - ;; restyle-range : (cons num num) style-delta% boolean -> void - (define/private (restyle-range r style need-undo?) - (when need-undo? (set! to-undo-styles (cons r to-undo-styles))) - (send text change-style style - (relative->text-position (car r)) - (relative->text-position (cdr r)))) - - ;; relative->text-position : number -> number - (define/private (relative->text-position pos) - (+ pos start-position)) - - ;; Initialize - (super-new) - (send/i controller controller<%> add-syntax-display this) - (initialize))) - -;; fixup-parentheses : string range -> void -(define (fixup-parentheses string range) - (for ([r (send/i range range<%> all-ranges)]) - (let ([stx (range-obj r)] - [start (range-start r)] - [end (range-end r)]) - (when (and (syntax? stx) (pair? (syntax-e stx))) - (case (syntax-property stx 'paren-shape) - ((#\[) - (string-set! string start #\[) - (string-set! string (sub1 end) #\])) - ((#\{) - (string-set! string start #\{) - (string-set! string (sub1 end) #\}))))))) - -(define (open-output-string/count-lines) - (let ([os (open-output-string)]) - (port-count-lines! os) - os)) - -;; code-style : text<%> number/#f -> style<%> -(define (code-style text font-size) - (let* ([style-list (send text get-style-list)] - [style (send style-list find-named-style (editor:get-default-color-style-name))]) - (if font-size - (send style-list find-or-create-style - style - (make-object style-delta% 'change-size font-size)) - style))) - -;; anchor-snip% -(define anchor-snip% - (class snip% - (define/override (copy) - (make-object string-snip% "")) - (super-instantiate ()))) - -;; Color translation - -;; translate-color : color-string -> color% -(define (translate-color color-string) - (let ([c (make-object color% color-string)]) - (if (pref:invert-colors?) - (let-values ([(r* g* b*) - (lightness-invert (send c red) (send c green) (send c blue))]) - #| - (printf "translate: ~s -> ~s\n" - (list (send c red) (send c green) (send c blue)) - (list r* g* b*)) - |# - (make-object color% r* g* b*)) - c))) - -;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8) -(define (lightness-invert r g b) - (define (c x) - (/ (exact->inexact x) 255.0)) - (define (d x) - (inexact->exact (round (* x 255)))) - (let-values ([(r g b) (lightness-invert* (c r) (c g) (c b))]) - (values (d r) (d g) (d b)))) - -(define (lightness-invert* R G B) - (let-values ([(Hp Sl L) (rgb->hsl* R G B)]) - (hsl*->rgb Hp Sl (- 1.0 L)))) - -(define (rgb->hsl* R G B) - (define M (max R G B)) - (define m (min R G B)) - (define C (- M m)) - (define Hp - (cond [(zero? C) - ;; Undefined, but use 0 - 0.0] - [(= M R) - (realmod* (/ (- G B) C) 6)] - [(= M G) - (+ (/ (- B R) C) 2)] - [(= M B) - (+ (/ (- R G) C) 4)])) - (define L (* 0.5 (+ M m))) - (define Sl - (cond [(zero? C) 0.0] - [(>= L 0.5) (/ C (* 2 L))] - [else (/ C (- 2 (* 2 L)))])) - - (values Hp Sl L)) - -(define (hsl*->rgb Hp Sl L) - (define C - (cond [(>= L 0.5) (* 2 L Sl)] - [else (* (- 2 (* 2 L)) Sl)])) - (define X (* C (- 1 (abs (- (realmod Hp 2) 1))))) - (define-values (R1 G1 B1) - (cond [(< Hp 1) (values C X 0)] - [(< Hp 2) (values X C 0)] - [(< Hp 3) (values 0 C X)] - [(< Hp 4) (values 0 X C)] - [(< Hp 5) (values X 0 C)] - [(< Hp 6) (values C 0 X)])) - (define m (- L (* 0.5 C))) - (values (+ R1 m) (+ G1 m) (+ B1 m))) - -;; realmod : real integer -> real -;; Adjusts a real number to [0, base] -(define (realmod x base) - (define xint (ceiling x)) - (define m (modulo xint base)) - (realmod* (- m (- xint x)) base)) - -;; realmod* : real real -> real -;; Adjusts a number in [-base, base] to [0,base] -;; Not a real mod, but faintly reminiscent. -(define (realmod* x base) - (if (negative? x) - (+ x base) - x)) - -;; Styles - -(define select-d - (make-object style-delta% 'change-weight 'bold)) - -(define underline-d - (make-object style-delta% 'change-underline #t)) - -(define (highlight-style-delta raw-color #:translate-color? [translate-color? #t]) - (let ([sd (new style-delta%)] - [color (if translate-color? (translate-color raw-color) raw-color)]) - (send sd set-delta-background color) - sd)) - -(define (mk-2-constant-style bow-color [wob-color (translate-color bow-color)]) - (let ([wob-version (highlight-style-delta wob-color #:translate-color? #f)] - [bow-version (highlight-style-delta bow-color #:translate-color? #f)]) - (λ () - (if (pref:invert-colors?) - wob-version - bow-version)))) - -(define get-secondary-highlight-d - (mk-2-constant-style "yellow" "darkgoldenrod")) - -#| -(define undo-select-d - (make-object style-delta% 'change-weight 'normal)) -(define get-undo-highlight-d - (mk-2-constant-style "white" "black")) -|# - -(define (get-undo-select/highlight-d) - (let ([sd (make-object style-delta% 'change-weight 'normal)] - [bg (if (pref:invert-colors?) "black" "white")]) - (send sd set-delta-background bg) - sd)) diff --git a/collects/macro-debugger/syntax-browser/embed.rkt b/collects/macro-debugger/syntax-browser/embed.rkt @@ -1,10 +0,0 @@ -#lang racket/base -(require "interfaces.rkt" - "widget.rkt" - "keymap.rkt" - "partition.rkt") - -(provide (all-from-out "interfaces.rkt") - (all-from-out "widget.rkt") - (all-from-out "keymap.rkt") - identifier=-choices) diff --git a/collects/macro-debugger/syntax-browser/frame.rkt b/collects/macro-debugger/syntax-browser/frame.rkt @@ -1,97 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - unstable/class-iop - "interfaces.rkt" - "partition.rkt" - "prefs.rkt" - "widget.rkt") -(provide browse-syntax - browse-syntaxes - make-syntax-browser - syntax-browser-frame% - syntax-widget/controls%) - -;; browse-syntax : syntax -> void -(define (browse-syntax stx) - (browse-syntaxes (list stx))) - -;; browse-syntaxes : (list-of syntax) -> void -(define (browse-syntaxes stxs) - (let ((w (make-syntax-browser))) - (for ([stx stxs]) - (send*/i w syntax-browser<%> - (add-syntax stx) - (add-separator))))) - -;; make-syntax-browser : -> syntax-browser<%> -(define (make-syntax-browser) - (let* ([view (new syntax-browser-frame%)]) - (send view show #t) - (send view get-widget))) - -;; syntax-browser-frame% -(define syntax-browser-frame% - (class* frame% () - (inherit get-width - get-height) - (init-field/i [config config<%> (new syntax-prefs%)]) - (super-new (label "Syntax Browser") - (width (send/i config config<%> get-width)) - (height (send/i config config<%> get-height))) - (define/i widget syntax-browser<%> - (new syntax-widget/controls% - (parent this) - (config config))) - (define/public (get-widget) widget) - (define/augment (on-close) - (send*/i config config<%> - (set-width (get-width)) - (set-height (get-height))) - (send widget shutdown) - (inner (void) on-close)))) - -;; syntax-widget/controls% -(define syntax-widget/controls% - (class* widget% () - (inherit get-main-panel - get-controller) - (super-new) - (inherit-field config) - - (define -control-panel - (new horizontal-pane% - (parent (get-main-panel)) - (stretchable-height #f))) - - ;; Put the control panel up front - (send (get-main-panel) change-children - (lambda (children) - (cons -control-panel (remq -control-panel children)))) - - (define -identifier=-choices (identifier=-choices)) - (define -choice - (new choice% (label "identifier=?") (parent -control-panel) - (choices (map car -identifier=-choices)) - (callback - (lambda (c e) - (send/i (get-controller) controller<%> set-identifier=? - (assoc (send c get-string-selection) - -identifier=-choices)))))) - (new button% - (label "Clear") - (parent -control-panel) - (callback (lambda _ (send/i (get-controller) controller<%> set-selected-syntax #f)))) - (new button% - (label "Properties") - (parent -control-panel) - (callback - (lambda _ - (send/i config config<%> set-props-shown? - (not (send/i config config<%> get-props-shown?)))))) - - (send/i (get-controller) controller<%> listen-identifier=? - (lambda (name+func) - (send -choice set-selection - (or (send -choice find-string (car name+func)) 0)))) - )) diff --git a/collects/macro-debugger/syntax-browser/keymap.rkt b/collects/macro-debugger/syntax-browser/keymap.rkt @@ -1,125 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - racket/pretty - unstable/gui/notify - "interfaces.rkt") -(provide syntax-keymap%) - -(define keymap/popup% - (class* keymap% (keymap/popup<%>) - (init editor) - (super-new) - (inherit add-function - map-function - chain-to-keymap) - - (define/public (add-context-menu-items menu) - (void)) - - (map-function "rightbutton" "popup-context-menu") - (add-function "popup-context-menu" - (lambda (editor event) - (popup-context-menu editor event))) - - (define/private (popup-context-menu 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)) - (define menu (new popup-menu%)) - (add-context-menu-items menu) - (send admin popup-menu menu x y)) - - ;; FIXME: move out of constructor to use sites - (chain-to-keymap (send editor get-keymap) #t) - (send editor set-keymap this))) - -(define syntax-keymap% - (class keymap/popup% - (init-field controller - config) - (inherit add-function - map-function - call-function - chain-to-keymap) - (super-new) - - (define/private (selected-syntax) - (send controller get-selected-syntax)) - - ;; Functionality - - (add-function "copy-syntax-as-text" - (lambda (_ event) - (define stx (send controller get-selected-syntax)) - (when stx - (send the-clipboard set-clipboard-string - (let ([out (open-output-string)]) - (pretty-print (syntax->datum stx) out) - (get-output-string out)) - (send event get-time-stamp))))) - - (add-function "clear-syntax-selection" - (lambda (i e) - (send controller set-selected-syntax #f))) - - (add-function "show-syntax-properties" - (lambda (i e) - (send config set-props-shown? #t))) - - (add-function "hide-syntax-properties" - (lambda (i e) - (send config set-props-shown? #f))) - - (define ((pretty-print-as sym) i e) - (let ([stx (selected-syntax)]) - (when (identifier? stx) - (send config set-pretty-styles - (hash-set (send config get-pretty-styles) - (syntax-e stx) - sym))))) - - (define/override (add-context-menu-items menu) - (new menu-item% (label "Copy") (parent menu) - (demand-callback - (lambda (i) - (send i enable (and (selected-syntax) #t)))) - (callback - (lambda (i e) - (call-function "copy-syntax-as-text" i e)))) - (new separator-menu-item% (parent menu)) - (new menu-item% - (label "Clear selection") - (parent menu) - (demand-callback - (lambda (i) - (send i enable (and (selected-syntax) #t)))) - (callback - (lambda (i e) - (call-function "clear-syntax-selection" i e)))) - (menu-option/notify-box menu "View syntax properties" - (get-field props-shown? config)) - (let ([pretty-menu - (new menu% - (label "Change layout") - (parent menu) - (demand-callback - (lambda (i) - (send i enable (and (identifier? (selected-syntax)) #t)))))]) - (for ([sym+desc '((and "like and") - (begin "like begin (0 up)") - (lambda "like lambda (1 up)") - (do "like do (2 up)"))]) - (new menu-item% - (label (format "Format identifier ~a" (cadr sym+desc))) - (parent pretty-menu) - (demand-callback - (lambda (i) - (let ([stx (selected-syntax)]) - (when (identifier? stx) - (send i set-label - (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))) - (callback - (pretty-print-as (car sym+desc))))))))) diff --git a/collects/macro-debugger/syntax-browser/prefs.rkt b/collects/macro-debugger/syntax-browser/prefs.rkt @@ -1,87 +0,0 @@ -#lang racket/base -(require racket/class - framework/preferences - "interfaces.rkt" - unstable/gui/notify - unstable/gui/prefs) -(provide prefs-base% - syntax-prefs-base% - syntax-prefs% - syntax-prefs/readonly% - - pref:invert-colors?) - -(preferences:set-default 'SyntaxBrowser:Width 700 number?) -(preferences:set-default 'SyntaxBrowser:Height 600 number?) -(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) -(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?) -(preferences:set-default 'SyntaxBrowser:DrawArrows? #t boolean?) - -(define pref:width (pref:get/set 'SyntaxBrowser:Width)) -(define pref:height (pref:get/set 'SyntaxBrowser:Height)) -(define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage)) -(define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown)) -(define pref:draw-arrows? (pref:get/set 'SyntaxBrowser:DrawArrows?)) - -(define pref:invert-colors? (pref:get/set 'framework:white-on-black?)) - -(define prefs-base% - (class object% - ;; suffix-option : SuffixOption - (define-notify suffix-option (new notify-box% (value 'over-limit))) - - ;; pretty-abbrev? : boolean - (define-notify pretty-abbrev? (new notify-box% (value #t))) - - ;; pretty-styles : ImmutableHash[symbol -> symbol] - (define-notify pretty-styles - (new notify-box% (value (make-immutable-hasheq null)))) - - ;; syntax-font-size : number/#f - ;; When non-false, overrides the default font size - (define-notify syntax-font-size (new notify-box% (value #f))) - - ;; colors : (listof string) - (define-notify colors - (new notify-box% (value the-colors))) - - (super-new))) - -(define alt-colors - '("black" - "red" "blue" "forestgreen" "purple" "brown" - "firebrick" "darkblue" "seagreen" "violetred" "chocolate" - "darkred" "cornflowerblue" "darkgreen" "indigo" "sandybrown" - "orange" "cadetblue" "olive" "mediumpurple" "goldenrod")) - -(define the-colors - '("black" "red" "blue" - "mediumforestgreen" "darkgreen" - "darkred" - "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue" - "indigo" "purple" - "orange" "salmon" "darkgoldenrod" "olive")) - -(define syntax-prefs-base% - (class* prefs-base% (config<%>) - (init readonly?) - - (define-syntax-rule (define-pref-notify* (name pref) ...) - (begin (define-notify name (notify-box/pref pref #:readonly? readonly?)) ...)) - - (define-pref-notify* - (width pref:width) - (height pref:height) - (props-percentage pref:props-percentage) - (props-shown? pref:props-shown?) - (draw-arrows? pref:draw-arrows?)) - - (super-new))) - -(define syntax-prefs% - (class syntax-prefs-base% - (super-new (readonly? #f)))) - -(define syntax-prefs/readonly% - (class syntax-prefs-base% - (super-new (readonly? #t)))) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.rkt b/collects/macro-debugger/syntax-browser/pretty-printer.rkt @@ -1,192 +0,0 @@ -#lang racket/base -(require racket/class - racket/pretty - racket/gui/base - racket/promise - "pretty-helper.rkt" - "interfaces.rkt") -(provide pretty-print-syntax) - -;; FIXME: Need to disable printing of structs with custom-write property - -;; pretty-print-syntax : syntax port partition number SuffixOption hasheq number bool -;; -> range% -(define (pretty-print-syntax stx port - primary-partition colors suffix-option styles columns abbrev?) - (define range-builder (new range-builder%)) - (define-values (datum ht:flat=>stx ht:stx=>flat) - (syntax->datum/tables stx primary-partition colors suffix-option abbrev?)) - (define identifier-list - (filter identifier? (hash-map ht:stx=>flat (lambda (k v) k)))) - (define (flat=>stx obj) - (hash-ref ht:flat=>stx obj #f)) - (define (stx=>flat stx) - (hash-ref ht:stx=>flat stx)) - (define (current-position) - (let-values ([(line column position) (port-next-location port)]) - (sub1 position))) - (define (pp-pre-hook obj port) - (when (flat=>stx obj) - (send range-builder push! (current-position))) - (send range-builder set-start obj (current-position))) - (define (pp-post-hook obj port) - (define stx (flat=>stx obj)) - (when stx - (send range-builder pop! stx (current-position))) - (let ([start (send range-builder get-start obj)] - [end (current-position)]) - (when (and start stx) - (send range-builder add-range stx (cons start end))))) - - (unless (syntax? stx) - (raise-type-error 'pretty-print-syntax "syntax" stx)) - (parameterize - ([pretty-print-pre-print-hook pp-pre-hook] - [pretty-print-post-print-hook pp-post-hook] - [pretty-print-size-hook pp-size-hook] - [pretty-print-print-hook pp-print-hook] - [pretty-print-remap-stylable pp-remap-stylable] - [pretty-print-abbreviate-read-macros abbrev?] - [pretty-print-current-style-table (pp-better-style-table styles)] - [pretty-print-columns columns]) - (pretty-print/defaults datum port) - (new range% - (range-builder range-builder) - (identifier-list identifier-list)))) - -(define (pp-print-hook obj display-like? port) - (cond [(syntax-dummy? obj) - ((if display-like? display write) (syntax-dummy-val obj) port)] - [(is-a? obj editor-snip%) - (write-special obj port)] - [else - (error 'pretty-print-hook "unexpected special value: ~e" obj)])) - -(define (pp-size-hook obj display-like? port) - (cond [(is-a? obj editor-snip%) - (pretty-print-columns)] - [(syntax-dummy? obj) - (let ((ostring (open-output-string))) - ((if display-like? display write) (syntax-dummy-val obj) ostring) - (string-length (get-output-string ostring)))] - [else #f])) - -(define (pp-remap-stylable obj) - (and (id-syntax-dummy? obj) - (let ([remap (id-syntax-dummy-remap obj)]) - (and (not (memq remap special-expression-keywords)) - remap)))) - -(define (pp-better-style-table styles) - (define style-list (for/list ([(k v) (in-hash styles)]) (cons k v))) - (pretty-print-extend-style-table - (basic-style-list) - (map car style-list) - (map cdr style-list))) - -(define (basic-style-list) - (pretty-print-extend-style-table - (pretty-print-current-style-table) - (map car basic-styles) - (map cdr basic-styles))) -(define basic-styles - '((define-values . define) - (define-syntaxes . define-syntax) - (define-for-syntax . define) - (define-values-for-syntax . define)) - #| - ;; Messes up formatting too much :( - (let* ([pref (pref:tabify)] - [table (car pref)] - [begin-rx (cadr pref)] - [define-rx (caddr pref)] - [lambda-rx (cadddr pref)]) - (let ([style-list (hash-table-map table cons)]) - (pretty-print-extend-style-table - (basic-style-list) - (map car style-list) - (map cdr style-list)))) - |#) - -(define-local-member-name range:get-ranges) - -;; range-builder% -(define range-builder% - (class object% - (define starts (make-hasheq)) - (define ranges (make-hasheq)) - - (define/public (set-start obj n) - (hash-set! starts obj n)) - - (define/public (get-start obj) - (hash-ref starts obj #f)) - - (define/public (add-range obj range) - (hash-set! ranges obj (cons range (get-ranges obj)))) - - (define (get-ranges obj) - (hash-ref ranges obj null)) - - (define/public (range:get-ranges) ranges) - - ;; ---- - - (define/public (get-subs) - working-subs) - - (define working-start #f) - (define working-subs null) - (define saved-starts null) - (define saved-subss null) - - (define/public (push! start) - (set! saved-starts (cons working-start saved-starts)) - (set! saved-subss (cons working-subs saved-subss)) - (set! working-start start) - (set! working-subs null)) - - (define/public (pop! stx end) - (define latest (make-treerange stx working-start end (reverse working-subs))) - (set! working-start (car saved-starts)) - (set! working-subs (car saved-subss)) - (set! saved-starts (cdr saved-starts)) - (set! saved-subss (cdr saved-subss)) - (set! working-subs (cons latest working-subs))) - - (super-new))) - -;; range% -(define range% - (class* object% (range<%>) - (init range-builder) - (init-field identifier-list) - (super-new) - - (define ranges (hash-copy (send range-builder range:get-ranges))) - (define subs (reverse (send range-builder get-subs))) - - (define/public (get-ranges obj) - (hash-ref ranges obj null)) - - (define/public (get-treeranges) - subs) - - (define/public (all-ranges) - (force sorted-ranges)) - - (define/public (get-identifier-list) - identifier-list) - - (define sorted-ranges - (delay - (sort - (apply append - (hash-map - ranges - (lambda (k vs) - (map (lambda (v) (make-range k (car v) (cdr v))) vs)))) - (lambda (x y) - (>= (- (range-end x) (range-start x)) - (- (range-end y) (range-start y))))))) - )) diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/collects/macro-debugger/syntax-browser/properties.rkt @@ -1,356 +0,0 @@ -#lang racket/base -(require racket/class - racket/match - racket/gui/base - framework - unstable/class-iop - "interfaces.rkt" - "util.rkt" - "../util/mpi.rkt" - "../util/stxobj.rkt") -(provide properties-view% - properties-snip%) - -(define color-text-default-style-name - "macro-debugger/syntax-browser/properties color-text% basic") - -(define color-text% - (class (editor:standard-style-list-mixin text:basic%) - (inherit get-style-list) - (define/override (default-style-name) - color-text-default-style-name) - (super-new) - (let* ([sl (get-style-list)] - [standard - (send sl find-named-style (editor:get-default-color-style-name))] - [basic - (send sl find-or-create-style standard - (make-object style-delta% 'change-family 'default))]) - (send sl new-named-style color-text-default-style-name basic)))) - -;; properties-view-base-mixin -(define properties-view-base-mixin - (mixin () () - ;; controller : controller<%> - (init-field controller) - - ;; selected-syntax : syntax - (field (selected-syntax #f)) - - ;; mode : maybe symbol in '(term stxobj) - (define mode 'term) - - ;; text : text% - (field (text (new color-text%))) - (field (pdisplayer (new properties-displayer% (text text)))) - - (send/i controller selection-manager<%> listen-selected-syntax - (lambda (stx) - (set! selected-syntax stx) - (refresh))) - (super-new) - - ;; get-mode : -> symbol - (define/public (get-mode) mode) - - ;; set-mode : symbol -> void - (define/public (set-mode m) - (set! mode m) - (refresh)) - - ;; refresh : -> void - (define/public (refresh) - (with-unlock text - (send text erase) - (if (syntax? selected-syntax) - (refresh/mode mode) - (refresh/mode #f))) - (send text scroll-to-position 0)) - - ;; refresh/mode : symbol -> void - (define/public (refresh/mode mode) - (case mode - ((term) (send pdisplayer display-meaning-info selected-syntax)) - ((stxobj) (send pdisplayer display-stxobj-info selected-syntax)) - ((#f) (send pdisplayer display-null-info)) - (else (error 'properties-view-base:refresh - "internal error: no such mode: ~s" mode)))) - - (send text set-styles-sticky #f) - #;(send text hide-caret #t) - (send text lock #t) - (refresh))) - - -;; properties-snip% -(define properties-snip% - (class (properties-view-base-mixin editor-snip%) - (inherit-field text) - (inherit-field pdisplayer) - (inherit set-mode) - - (define/private outer:insert - (case-lambda - [(obj) - (outer:insert obj style:normal)] - [(text style) - (outer:insert text style #f)] - [(text style clickback) - (let ([start (send outer-text last-position)]) - (send outer-text insert text) - (let ([end (send outer-text last-position)]) - (send outer-text change-style style start end #f) - (when clickback - (send outer-text set-clickback start end clickback))))])) - - (define outer-text (new text%)) - (super-new (editor outer-text)) - (outer:insert "Term" style:hyper (lambda _ (set-mode 'term))) - (outer:insert " ") - (outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj))) - (outer:insert "\n") - (outer:insert (new editor-snip% (editor text))) - (send outer-text hide-caret #t) - (send outer-text lock #t))) - -;; properties-view% -(define properties-view% - (class* (properties-view-base-mixin object%) () - (init parent) - (inherit-field text) - (inherit-field pdisplayer) - (inherit set-mode) - - ;; get-tab-choices : (listof (cons string thunk)) - ;; Override to add or remove panels - (define/public (get-tab-choices) - (list (cons "Term" 'term) - (cons "Syntax Object" 'stxobj))) - - (super-new) - (define tab-choices (get-tab-choices)) - (define tab-panel - (new tab-panel% - (choices (map car tab-choices)) - (parent parent) - (callback - (lambda (tp e) - (set-mode (cdr (list-ref tab-choices (send tp get-selection)))))))) - (define ecanvas (new canvas:color% (editor text) (parent tab-panel))))) - -;; properties-displayer% -(define properties-displayer% - (class* object% () - (init-field text) - - ;; display-null-info : -> void - (define/public (display-null-info) - (display "No syntax selected\n" n/a-sd)) - - ;; display-meaning-info : syntax -> void - (define/public (display-meaning-info stx) - (when (and (identifier? stx) - (uninterned? (syntax-e stx))) - (display "Uninterned symbol!\n\n" key-sd)) - (display-binding-info stx) - (display-indirect-binding-info stx)) - - ;; display-binding-info : syntax -> void - (define/private (display-binding-info stx) - (display "Apparent identifier binding\n" key-sd) - (display-bindings stx)) - - ;; display-indirect-binding-info : syntax -> void - (define/private (display-indirect-binding-info stx) - (cond - [(identifier? stx) - (display "Binding if used for #%top\n" key-sd) - (display-bindings (datum->syntax stx '#%top))] - [(and (syntax? stx) (pair? (syntax-e stx))) - (display "Binding if used for #%app\n" key-sd) - (display-bindings (datum->syntax stx '#%app))] - [else - (display "Binding if used for #%datum\n" key-sd) - (display-bindings (datum->syntax stx '#%datum))])) - - ;; display-bindings : syntax -> void - (define/private (display-bindings stx) - (define phases-to-search '(0 1 -1 #f 2 3 4 5 -2 -3 -4 -5)) - (unless (identifier? stx) - (display "Not applicable\n\n" n/a-sd)) - (when (identifier? stx) - (cond [(eq? (identifier-binding stx) 'lexical) - (display "lexical (all phases)\n" #f)] - [else - (let ([bindings (for/hash ([phase (in-list phases-to-search)]) - (values phase (identifier-binding stx phase)))]) - (cond [(for/or ([(p b) (in-hash bindings)]) b) - (for ([phase (in-list phases-to-search)]) - (display-binding-kvs phase (hash-ref bindings phase #f) stx))] - [else (display "none\n" #f)]))]) - (display "\n" #f))) - - ;; display-binding-kvs : phase bindinginfo identifier -> void - (define/private (display-binding-kvs phase v stx) - (when v - (display (format "in phase ~a~a:" - phase - (case phase - ((1) " (transformer phase)") - ((-1) " (template phase)") - ((#f) " (label phase)") - (else ""))) - sub-key-sd) - (display "\n" #f) - (match v - [(list* def-mpi def-sym imp-mpi imp-sym defined-at-phase _) - (display-subkv " defined in" (mpi->string def-mpi)) - (unless (eq? def-sym (syntax-e stx)) - (display-subkv " as" def-sym)) - (display-subkv " imported from" (mpi->string imp-mpi)) - (unless (eq? imp-sym (syntax-e stx)) - (display-subkv " provided as" (list-ref v 3))) - (unless (zero? defined-at-phase) - (display-subkv " defined at phase" defined-at-phase))] - [_ (void)]))) - - ;; display-stxobj-info : syntax -> void - (define/public (display-stxobj-info stx) - (display-source-info stx) - (display-extra-source-info stx) - (display-symbol-property-info stx) - (display-marks stx) - ;; Disable until correct: - (when #f (display-taint stx))) - - ;; display-source-info : syntax -> void - (define/private (display-source-info stx) - (define s-source (syntax-source stx)) - (define s-line (syntax-line stx)) - (define s-column (syntax-column stx)) - (define s-position (syntax-position stx)) - (define s-span (syntax-span stx)) - (define s-span-known? (not (memv s-span '(0 #f)))) - (display "Source location\n" key-sd) - (if (or s-source s-line s-column s-position s-span-known?) - (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-span)) - (display "No source location available\n" n/a-sd)) - (display "\n" #f)) - - ;; display-extra-source-info : syntax -> void - (define/private (display-extra-source-info stx) - (display "Built-in properties\n" key-sd) - (display-subkv "source module" - (let ([mod (syntax-source-module stx)]) - (and mod (mpi->string mod)))) - (display-subkv "original?" (syntax-original? stx)) - (display "\n" #f)) - - ;; display-symbol-property-info : syntax -> void - (define/private (display-symbol-property-info stx) - (let ([keys (syntax-property-symbol-keys stx)]) - (display "Additional properties\n" key-sd) - (when (null? keys) - (display "No additional properties available.\n" n/a-sd)) - (when (pair? keys) - (for-each (lambda (k) (display-subkv/value k (syntax-property stx k))) - keys)) - (display "\n" #f))) - - ;; display-marks : syntax -> void - (define/private (display-marks stx) - (display "Marks: " key-sd) - (display (format "~s\n" (get-marks stx)) #f) - (display "\n" #f)) - - ;; display-taint : syntax -> void - (define/private (display-taint stx) - (define (syntax-armed? stx) - (syntax-tainted? (datum->syntax stx 'dummy))) - (display "Tamper status: " key-sd) - (display (cond [(syntax-tainted? stx) - "tainted"] - [(syntax-armed? stx) - "armed"] - [else "clean"]) - #f)) - - ;; display-kv : any any -> void - (define/private (display-kv key value) - (display (format "~a\n" key) key-sd) - (display (format "~s\n\n" value) #f)) - - ;; display-subkv : any any -> void - (define/public (display-subkv k v) - (display (format "~a: " k) sub-key-sd) - (display (format "~a\n" v) #f)) - - (define/public (display-subkv/value k v) - (display-subkv k v) - #; - (begin - (display (format "~a:\n" k) sub-key-sd) - (let* ([value-text (new text:standard-style-list% (auto-wrap #t))] - [value-snip (new editor-snip% (editor value-text))] - [value-port (make-text-port value-text)]) - (set-interactive-write-handler value-port) - (set-interactive-print-handler value-port) - (set-interactive-display-handler value-port) - (write v value-port) - (send value-text lock #t) - (send text insert value-snip) - (send text insert "\n") - #;(send ecanvas add-wide-snip value-snip)))) - - ;; display : string style-delta -> void - (define/private (display item sd) - (let ([p0 (send text last-position)]) - (send text insert item) - (let ([p1 (send text last-position)]) - (send text change-style sd p0 p1)))) - - (super-new))) - - -;; lift/id : (identifier -> void) 'a -> void -(define (lift/id f) - (lambda (stx) (when (identifier? stx) (f stx)))) - -(define (uninterned? s) - (not (eq? s (string->symbol (symbol->string s))))) - -(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") - (send sd set-weight-on 'bold) - sd)) - -(define sub-key-sd - (let ([sd (new style-delta%)]) - (send sd set-delta-foreground "blue") - sd)) - -(define n/a-sd - (let ([sd (new style-delta%)]) - (send sd set-delta-foreground "gray") - sd)) - -(define style:normal (make-object style-delta% 'change-normal)) - -(define style:hyper - (let ([s (make-object style-delta% 'change-normal)]) - (send s set-delta 'change-toggle-underline) - (send s set-delta-foreground "blue") - s)) diff --git a/collects/macro-debugger/syntax-browser/snip-decorated.rkt b/collects/macro-debugger/syntax-browser/snip-decorated.rkt @@ -1,208 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - (only-in mzlib/string read-from-string) - unstable/class-iop - "interfaces.rkt" - "controller.rkt" - "properties.rkt" - "prefs.rkt" - "util.rkt" - (except-in "snip.rkt" - snip-class)) - -(provide decorated-syntax-snip% - snip-class) - -(define top-aligned - (make-object style-delta% 'change-alignment 'top)) - -(define-struct styled (contents style clickback)) - -;; clicky-snip% -(define clicky-snip% - (class* editor-snip% () - - (init-field [open-style '(border)] - [closed-style '(tight-text-fit)]) - - (inherit set-margin - set-inset - set-snipclass - set-tight-text-fit - show-border - get-admin) - - (define -outer (new text%)) - (super-new (editor -outer) (with-border? #f)) - (set-margin 2 2 2 2) - (set-inset 2 2 2 2) - ;;(set-margin 3 0 0 0) - ;;(set-inset 1 0 0 0) - ;;(set-margin 0 0 0 0) - ;;(set-inset 0 0 0 0) - - (define/public (closed-contents) null) - (define/public (open-contents) null) - - (define open? #f) - - (define/public (refresh-contents) - (with-unlock -outer - (send -outer erase) - (do-style (if open? open-style closed-style)) - (outer:insert (if open? (hide-icon) (show-icon)) - style:hyper - (if open? - (lambda _ - (set! open? #f) - (refresh-contents)) - (lambda _ - (set! open? #t) - (refresh-contents)))) - (for-each (lambda (s) (outer:insert s)) - (if open? (open-contents) (closed-contents))) - (send -outer change-style top-aligned 0 (send -outer last-position)))) - - (define/private (do-style style) - (show-border (memq 'border style)) - (set-tight-text-fit (memq 'tight-text-fit style))) - - (define/private outer:insert - (case-lambda - [(obj) - (if (styled? obj) - (outer:insert (styled-contents obj) - (styled-style obj) - (styled-clickback obj)) - (outer:insert obj style:normal))] - [(text style) - (outer:insert text style #f)] - [(text style clickback) - (let ([start (send -outer last-position)]) - (send -outer insert text) - (let ([end (send -outer last-position)]) - (send -outer change-style style start end #f) - (when clickback - (send -outer set-clickback start end clickback))))])) - - (send -outer hide-caret #t) - (send -outer lock #t) - (refresh-contents) - )) - -;; decorated-syntax-snip% -(define decorated-syntax-snip% - (class* clicky-snip% (readable-snip<%>) - (init-field ((stx syntax))) - (init-field [controller (new controller%)]) - (init-field [config (new syntax-prefs%)]) - - (inherit set-snipclass - refresh-contents) - - (define the-syntax-snip - (new syntax-snip% - (syntax stx) - (controller controller) - (config config))) - (define the-summary - (let* ([t (new text%)] - [es (new editor-snip% (editor t) (with-border? #f))]) - (send es set-margin 0 0 0 0) - (send es set-inset 0 0 0 0) - (send t insert (format "~s" stx)) - es)) - - (define properties-snip - (new properties-container-snip% - (controller controller))) - - (define/override (closed-contents) - (list the-summary)) - - (define/override (open-contents) - (list " " - the-syntax-snip - " " - properties-snip)) - - ;; Snip methods - (define/override (copy) - (new decorated-syntax-snip% - (syntax stx) - (controller controller) - (config config))) - (define/override (write stream) - (send stream put - (string->bytes/utf-8 - (format "~s" (marshall-syntax stx))))) - (define/public (read-special src line col pos) - (send the-syntax-snip read-special src line col pos)) - - (send/i config config<%> listen-props-shown? - (lambda (?) (refresh-contents))) - - (super-new) - (set-snipclass snip-class) - )) - -(define properties-container-snip% - (class clicky-snip% - (init controller) - - (define properties-snip - (new properties-snip% (controller controller))) - - (define/override (open-contents) - (list #;(show-properties-icon) - properties-snip)) - - (define/override (closed-contents) - (list (show-properties-icon))) - - (super-new (open-style '()) - (closed-style '())))) - -(define style:normal (make-object style-delta% 'change-normal)) -(define style:hyper - (let ([s (make-object style-delta% 'change-normal)]) - (send s set-delta 'change-toggle-underline) - (send s set-delta-foreground "blue") - s)) -(define style:green - (let ([s (make-object style-delta% 'change-normal)]) - (send s set-delta-foreground "darkgreen") - s)) -(define style:bold - (let ([s (make-object style-delta% 'change-normal)]) - (send s set-delta 'change-bold) - s)) - -(define (show-icon) - (make-object image-snip% - (build-path (collection-path "icons") "turn-up.png"))) -(define (hide-icon) - (make-object image-snip% - (build-path (collection-path "icons") "turn-down.png"))) - -(define (show-properties-icon) - (make-object image-snip% - (build-path (collection-path "icons") "syncheck.png"))) - - -;; SNIPCLASS - -;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt -(define decorated-syntax-snipclass% - (class snip-class% - (define/override (read stream) - (new decorated-syntax-snip% - (syntax (unmarshall-syntax - (read-from-string (send stream get-bytes)))))) - (super-new))) - -(define snip-class (make-object decorated-syntax-snipclass%)) -(send snip-class set-version 2) -(send snip-class set-classname - (format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.rkt"))) diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt @@ -1,475 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - data/interval-map - drracket/arrow - framework - data/interval-map - "interfaces.rkt") - -(provide text:hover<%> - text:hover-drawings<%> - text:arrows<%> - - text:hover-mixin - text:hover-drawings-mixin - text:tacking-mixin - text:arrows-mixin - text:region-data-mixin - text:clickregion-mixin - browser-text%) - -(define arrow-cursor (make-object cursor% 'arrow)) - -(define arrow-brush - (send the-brush-list find-or-create-brush "white" 'solid)) -(define (tacked-arrow-brush color) - (send the-brush-list find-or-create-brush color 'solid)) - -(define billboard-brush - (send the-brush-list find-or-create-brush "white" 'solid)) - -(define white (send the-color-database find-color "white")) - -;; A Drawing is (make-drawing (??? -> void) (box boolean)) -(define-struct drawing (draw tacked?)) - -(define-struct idloc (start end id)) - -(define (mean x y) - (/ (+ x y) 2)) - -;; save+restore pen, brush, also smoothing -(define-syntax with-saved-pen&brush - (syntax-rules () - [(with-saved-pen&brush dc . body) - (save-pen&brush dc (lambda () . body))])) - -(define (save-pen&brush dc thunk) - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [old-smoothing (send dc get-smoothing)]) - (begin0 (thunk) - (send* dc - (set-pen old-pen) - (set-brush old-brush) - (set-smoothing old-smoothing))))) - -(define-syntax with-saved-text-config - (syntax-rules () - [(with-saved-text-config dc . body) - (save-text-config dc (lambda () . body))])) - -(define (save-text-config dc thunk) - (let ([old-font (send dc get-font)] - [old-color (send dc get-text-foreground)] - [old-background (send dc get-text-background)] - [old-mode (send dc get-text-mode)]) - (begin0 (thunk) - (send* dc - (set-font old-font) - (set-text-foreground old-color) - (set-text-background old-background) - (set-text-mode old-mode))))) - -;; Interfaces - -(define text:region-data<%> - (interface (text:basic<%>) - get-region-mapping)) - -(define text:hover<%> - (interface (text:basic<%>) - update-hover-position)) - -(define text:hover-drawings<%> - (interface (text:basic<%>) - add-hover-drawing - get-position-drawings)) - -(define text:arrows<%> - (interface (text:hover-drawings<%>) - add-arrow - add-billboard)) - -;; Mixins - -(define text:region-data-mixin - (mixin (text:basic<%>) (text:region-data<%>) - - (define table (make-hasheq)) - - (define/public (get-region-mapping key) - (hash-ref! table key (lambda () (make-interval-map)))) - - (define/augment (after-delete start len) - (for ([im (in-hash-values table)]) - (interval-map-contract! im start (+ start len))) - (inner (void) after-delete start len)) - - (define/augment (after-insert start len) - (for ([im (in-hash-values table)]) - (interval-map-expand! im start (+ start len))) - (inner (void) after-insert start len)) - - (super-new))) - -(define text:hover-mixin - (mixin (text:basic<%>) (text:hover<%>) - (inherit dc-location-to-editor-location - find-position) - - (define/override (on-default-event ev) - (super on-default-event ev) - (case (send ev get-event-type) - ((enter motion leave) - (define-values (x y) - (let ([gx (send ev get-x)] - [gy (send ev get-y)]) - (dc-location-to-editor-location gx gy))) - (define on-it? (box #f)) - (define pos (find-position x y #f on-it?)) - (update-hover-position (and (unbox on-it?) pos))))) - - (define/public (update-hover-position pos) - (void)) - - (super-new))) - -(define text:hover-drawings-mixin - (mixin (text:hover<%> text:region-data<%>) (text:hover-drawings<%>) - (inherit dc-location-to-editor-location - find-position - invalidate-bitmap-cache - get-region-mapping) - (super-new) - - ;; interval-map of Drawings - (define drawings-list (get-region-mapping 'hover-drawings)) - - (field [hover-position #f]) - - (define/override (update-hover-position pos) - (define old-pos hover-position) - (super update-hover-position pos) - (set! hover-position pos) - (unless (same-drawings? old-pos pos) - (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))) - - (define/public (add-hover-drawing start end draw [tack-box (box #f)]) - (let ([drawing (make-drawing draw tack-box)]) - (interval-map-cons*! drawings-list - start (add1 end) - drawing - null))) - - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (super on-paint before? dc left top right bottom dx dy draw-caret) - (unless before? - (for ([d (get-position-drawings hover-position)]) - ((drawing-draw d) this dc left top right bottom dx dy)))) - - (define/public (get-position-drawings pos) - (if pos (interval-map-ref drawings-list pos null) null)) - - (define/private (same-drawings? old-pos pos) - ;; relies on order drawings added & list-of-eq?-struct equality - (equal? (get-position-drawings old-pos) - (get-position-drawings pos))))) - -(define text:tacking-mixin - (mixin (text:basic<%> text:hover-drawings<%>) () - (inherit get-canvas - get-keymap - get-position-drawings) - (inherit-field hover-position) - (super-new) - - (define tacked-table (make-hasheq)) - - (define/override (on-local-event ev) - (case (send ev get-event-type) - ((right-down) - (if (pair? (get-position-drawings hover-position)) - (send (get-canvas) popup-menu - (make-tack/untack-menu (get-position-drawings hover-position)) - (send ev get-x) - (send ev get-y)) - (super on-local-event ev))) - (else - (super on-local-event ev)))) - - ;; Clear tacked-table on any modification. - ;; FIXME: possible to be more precise? (but not needed for macro stepper) - (define/augment (after-delete start len) - (set! tacked-table (make-hasheq)) - (inner (void) after-delete start len)) - (define/augment (after-insert start len) - (set! tacked-table (make-hasheq)) - (inner (void) after-insert start len)) - - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (super on-paint before? dc left top right bottom dx dy draw-caret) - (unless before? - (for ([draw (in-hash-keys tacked-table)]) - (draw this dc left top right bottom dx dy)))) - - (define/private (make-tack/untack-menu drawings) - (define menu (new popup-menu%)) - (define keymap (get-keymap)) - (define tack-item - (new menu-item% (label "Tack") - (parent menu) - (callback (lambda _ (tack drawings))))) - (define untack-item - (new menu-item% (label "Untack") - (parent menu) - (callback (lambda _ (untack drawings))))) - (send tack-item enable - (for/or ([d (in-list drawings)]) (not (unbox (drawing-tacked? d))))) - (send untack-item enable - (for/or ([d (in-list drawings)]) (unbox (drawing-tacked? d)))) - (when (is-a? keymap keymap/popup<%>) - (new separator-menu-item% (parent menu)) - (send keymap add-context-menu-items menu)) - menu) - - (define/private (tack drawings) - (for ([d (in-list drawings)]) - (hash-set! tacked-table (drawing-draw d) #t) - (set-box! (drawing-tacked? d) #t))) - (define/private (untack drawings) - (for ([d (in-list drawings)]) - (hash-remove! tacked-table (drawing-draw d)) - (set-box! (drawing-tacked? d) #f))))) - -(define text:arrows-mixin - (mixin (text:hover-drawings<%>) (text:arrows<%>) - (inherit position-location - add-hover-drawing - find-wordbreak) - - (define/public (add-billboard pos1 pos2 str color-name) - (define color (send the-color-database find-color color-name)) - (let ([draw - (lambda (text dc left top right bottom dx dy) - (let-values ([(x y) (range->mean-loc pos1 pos1)] - [(fw fh _d _v) (send dc get-text-extent "y")]) - (with-saved-pen&brush dc - (with-saved-text-config dc - (send* dc - (set-pen color 1 'solid) - (set-brush billboard-brush) - (set-text-mode 'solid) - (set-font (billboard-font dc)) - (set-text-foreground color)) - (let-values ([(w h d v) (send dc get-text-extent str)] - [(adj-y) fh] - [(mini) _d]) - (send* dc - (set-smoothing 'smoothed) - (draw-rounded-rectangle - (+ x dx) - (+ y dy adj-y) - (+ w mini mini) - (+ h mini mini)) - (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))]) - (add-hover-drawing pos1 pos2 draw))) - - (define/public (add-arrow from1 from2 to1 to2 color-name label where) - (define color (send the-color-database find-color color-name)) - (define tack-box (box #f)) - (unless (and (= from1 to1) (= from2 to2)) - (let ([draw - (lambda (text dc left top right bottom dx dy) - (let-values ([(startx starty) (range->mean-loc from1 from2)] - [(endx endy) (range->mean-loc to1 to2)] - [(fw fh _d _v) (send dc get-text-extent "x")] - [(lw lh ld _V) (send dc get-text-extent (or label "x"))]) - (with-saved-pen&brush dc - (with-saved-text-config dc - (send dc set-pen color 1 'solid) - (send dc set-brush - (if (unbox tack-box) - (tacked-arrow-brush color) - arrow-brush)) - (draw-arrow dc startx - (+ starty (/ fh 2)) - endx - (+ endy (/ fh 2)) - dx dy) - (when label - (let* ([lx (+ endx dx fw)] - [ly (- (+ endy dy) fh)]) - (send* dc - (set-brush billboard-brush) - (set-font (billboard-font dc)) - (set-text-foreground color) - (set-smoothing 'smoothed) - (draw-rounded-rectangle (- lx ld) (- ly ld) - (+ lw ld ld) (+ lh ld ld)) - (draw-text label lx ly))))))))]) - (add-hover-drawing from1 from2 draw tack-box) - (add-hover-drawing to1 to2 draw tack-box)))) - - (define/private (position->location p) - (define xbox (box 0.0)) - (define ybox (box 0.0)) - (position-location p xbox ybox) - (values (unbox xbox) (unbox ybox))) - - (define/private (?-font dc) - (let ([size (send (send dc get-font) get-point-size)]) - (send the-font-list find-or-create-font size 'default 'normal 'bold))) - - (define/private (billboard-font dc) - (let ([size (send (send dc get-font) get-point-size)]) - (send the-font-list find-or-create-font size 'default 'normal))) - - (define/private (range->mean-loc pos1 pos2) - (let*-values ([(loc1x loc1y) (position->location pos1)] - [(loc2x loc2y) (position->location pos2)] - [(locx) (mean loc1x loc2x)] - [(locy) (mean loc1y loc2y)]) - (values locx locy))) - - (super-new))) - -#| -text:clickregion-mixin - -Like clickbacks, but: - - use interval-map to avoid linear search - (major problem w/ macro stepper and large expansions!) - - callback takes position of click, not (start, end) - - different rules for removal - - TODO: extend to double-click -|# -(define text:clickregion-mixin - (mixin (text:region-data<%>) () - (inherit get-admin - get-region-mapping - dc-location-to-editor-location - find-position) - - (super-new) - - ;; Two mappings: one for left clicks, another for right - ;; mouse-downs. Rationale: macro stepper wants to handle left - ;; clicks normally, but wants to insert behavior (ie, change - ;; focus) before normal processing of right-down (ie, editor - ;; passes to keymap, opens popup menu). - (define clickbacks (get-region-mapping 'click-region)) - (define right-clickbacks (get-region-mapping 'right-click-region)) - (define tracking #f) - - (define/public (set-clickregion start end callback [region 'click]) - (let ([mapping - (case region - ((click) clickbacks) - ((right-down) right-clickbacks) - (else (error 'set-clickregion - "bad region symbol: expected 'click or 'right-down, got ~e" - region)))]) - (if callback - (interval-map-set! mapping start end callback) - (interval-map-remove! mapping start end)))) - - (define/private (get-event-position ev) - (define-values (x y) - (let ([gx (send ev get-x)] - [gy (send ev get-y)]) - (dc-location-to-editor-location gx gy))) - (define on-it? (box #f)) - (define pos (find-position x y #f on-it?)) - (and (unbox on-it?) pos)) - - ;; on-default-event called if keymap does not handle event - (define/override (on-default-event ev) - (define admin (get-admin)) - (when admin - (define pos (get-event-position ev)) - (case (send ev get-event-type) - ((left-down) - (set! tracking (and pos (interval-map-ref clickbacks pos #f))) - (send admin update-cursor)) - ((left-up) - (when tracking - (let ([cb (and pos (interval-map-ref clickbacks pos #f))] - [tracking* tracking]) - (set! tracking #f) - (when (eq? tracking* cb) - (cb pos))) - (send admin update-cursor))))) - (super on-default-event ev)) - - ;; on-local-event called before keymap consulted - (define/override (on-local-event ev) - (case (send ev get-event-type) - ((right-down) - (when (get-admin) - (define pos (get-event-position ev)) - (let ([cb (and pos (interval-map-ref right-clickbacks pos #f))]) - (when cb (cb pos)))))) - (super on-local-event ev)) - - (define/override (adjust-cursor ev) - (define pos (get-event-position ev)) - (define cb (and pos (interval-map-ref clickbacks pos #f))) - (if cb - arrow-cursor - (super adjust-cursor ev))))) - - -#| -(define text:hover-identifier<%> - (interface () - get-hovered-identifier - set-hovered-identifier - listen-hovered-identifier)) - -(define text:hover-identifier-mixin - (mixin (text:hover<%>) (text:hover-identifier<%>) - (define-notify hovered-identifier (new notify-box% (value #f))) - - (define idlocs null) - - (define/public (add-identifier-location start end id) - (set! idlocs (cons (make-idloc start end id) idlocs))) - - (define/public (delete-all-identifier-locations) - (set! idlocs null) - (set-hovered-identifier #f)) - - (define/override (update-hover-position pos) - (super update-hover-position pos) - (let search ([idlocs idlocs]) - (cond [(null? idlocs) (set-hovered-identifier #f)] - [(and (<= (idloc-start (car idlocs)) pos) - (< pos (idloc-end (car idlocs)))) - (set-hovered-identifier (idloc-id (car idlocs)))] - [else (search (cdr idlocs))]))) - (super-new))) -|# - - -(define browser-text% - (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) - (class (text:clickregion-mixin - (text:arrows-mixin - (text:tacking-mixin - (text:hover-drawings-mixin - (text:hover-mixin - (text:region-data-mixin - (text:hide-caret/selection-mixin - (text:foreground-color-mixin - (editor:standard-style-list-mixin text:basic%))))))))) - (inherit set-autowrap-bitmap get-style-list) - (define/override (default-style-name) browser-text-default-style-name) - (super-new (auto-wrap #t)) - (let* ([sl (get-style-list)] - [standard (send sl find-named-style (editor:get-default-color-style-name))] - [browser-basic (send sl find-or-create-style standard - (make-object style-delta% 'change-family 'default))]) - (send sl new-named-style browser-text-default-style-name browser-basic)) - (set-autowrap-bitmap #f)))) diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt @@ -1,269 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - racket/match - framework - syntax/id-table - unstable/class-iop - "interfaces.rkt" - "controller.rkt" - "display.rkt" - "keymap.rkt" - "hrule-snip.rkt" - "properties.rkt" - "text.rkt" - "util.rkt" - "../util/eomap.rkt" - "../util/logger.rkt" - "../util/mpi.rkt") -(provide widget%) - -;; widget% -;; A syntax widget creates its own syntax-controller. -(define widget% - (class* object% (syntax-browser<%> widget-hooks<%>) - (init parent) - (init-field config) - - (field [controller (new controller%)]) - - (define -main-panel - (new vertical-panel% (parent parent))) - (define -split-panel - (new panel:horizontal-dragable% (parent -main-panel))) - (define -text (new browser-text%)) - (define -ecanvas - (new canvas:color% (parent -split-panel) (editor -text))) - (define -props-panel - (new horizontal-panel% (parent -split-panel) (style '(deleted)))) - (define props - (new properties-view% - (parent -props-panel) - (controller controller))) - - (define/public (setup-keymap) - (new syntax-keymap% - (editor -text) - (controller controller) - (config config))) - - (send -text set-styles-sticky #f) - (send -text lock #t) - - (define/public (show-props show?) - (internal-show-props show?)) - - (define saved-props-percentage #f) - - (define/private (internal-show-props show?) - (if show? - (unless (send -props-panel is-shown?) - (send -split-panel begin-container-sequence) - (let ([p (or saved-props-percentage - (send/i config config<%> get-props-percentage))]) - (send -split-panel add-child -props-panel) - (update-props-percentage p)) - (send -props-panel show #t) - (send -split-panel end-container-sequence)) - (when (send -props-panel is-shown?) - (send -split-panel begin-container-sequence) - (set! saved-props-percentage - (cadr (send -split-panel get-percentages))) - (send -split-panel delete-child -props-panel) - (send -props-panel show #f) - (send -split-panel end-container-sequence)))) - - (define/private (update-props-percentage p) - (send -split-panel set-percentages - (list (- 1 p) p))) - - (define/private (props-panel-shown?) - (send -props-panel is-shown?)) - - ;; - - (define/public (get-controller) - controller) - - ;; - - (define/public (get-main-panel) - -main-panel) - - (define/public (shutdown) - (when (props-panel-shown?) - (send/i config config<%> set-props-percentage - (cadr (send -split-panel get-percentages))))) - - ;; syntax-browser<%> Methods - - (define/public (add-text text) - (with-unlock -text - (send -text insert text))) - - (define/public (add-error-text text) - (with-unlock -text - (let ([a (send -text last-position)]) - (send -text insert text) - (let ([b (send -text last-position)]) - (send -text change-style error-text-style a b))))) - - (define/public (add-clickback text handler) - (with-unlock -text - (let ([a (send -text last-position)]) - (send -text insert text) - (let ([b (send -text last-position)]) - (send -text set-clickback a b handler) - (send -text change-style clickback-style a b))))) - - (define/public (add-syntax stx - #:binders [binders '#hash()] - #:shift-table [shift-table '#hash()] - #:definites [definites #f] - #:hi-colors [hi-colors null] - #:hi-stxss [hi-stxss null] - #:substitutions [substitutions null]) - (define (get-shifted id) (hash-ref shift-table id null)) - - (with-unlock -text - (define display - (print-syntax-to-editor stx -text controller config - (calculate-columns) - (send -text last-position))) - (send -text insert "\n") - (define range (send/i display display<%> get-range)) - (define offset (send/i display display<%> get-start-position)) - (with-log-time "substitutions" - (for ([subst (in-list substitutions)]) - (for ([r (in-list (send/i range range<%> get-ranges (car subst)))]) - (send -text insert (cdr subst) - (+ offset (car r)) - (+ offset (cdr r)) - #f) - (send -text change-style - (code-style -text (send/i config config<%> get-syntax-font-size)) - (+ offset (car r)) - (+ offset (cdr r)) - #f)))) - ;; Apply highlighting - (with-log-time "highlights" - (for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)]) - (send/i display display<%> highlight-syntaxes hi-stxs hi-color))) - ;; Underline binders (and shifted binders) - (with-log-time "underline binders" - (send/i display display<%> underline-syntaxes - (let ([binder-list (hash-map binders (lambda (k v) k))]) - (append (apply append (map get-shifted binder-list)) - binder-list)))) - (send display refresh) - - ;; Make arrows (& billboards, when enabled) - (with-log-time "add arrows" - (when (send config get-draw-arrows?) - (define (definite-phase id) - (and definites - (or (eomap-ref definites id #f) - (for/or ([shifted (in-list (hash-ref shift-table id null))]) - (eomap-ref definites shifted #f))))) - - (define phase-binder-table (make-hash)) - (define (get-binder-table phase) - (hash-ref! phase-binder-table phase (lambda () (make-free-id-table #:phase phase)))) - (for ([(binder phase) (in-hash binders)]) - (free-id-table-set! (get-binder-table phase) binder binder)) - - (define (get-binders id phase) - (define (for-one-table table id) - (let ([binder (free-id-table-ref table id #f)]) - (cond [(not binder) null] - [shift-table (cons binder (get-shifted binder))] - [else (list binder)]))) - (cond [phase (for-one-table (get-binder-table phase) id)] - [else - (apply append - (for/list ([table (in-hash-values phase-binder-table)]) - (for-one-table table id)))])) - - (for ([id (in-list (send/i range range<%> get-identifier-list))]) - (define phase (definite-phase id)) - (when #f ;; DISABLED - (add-binding-billboard offset range id phase)) - (for ([binder (in-list (get-binders id phase))]) - (for ([binder-r (in-list (send/i range range<%> get-ranges binder))]) - (for ([id-r (in-list (send/i range range<%> get-ranges id))]) - (add-binding-arrow offset binder-r id-r phase))))))) - (void))) - - (define/private (add-binding-arrow start binder-r id-r phase) - ;; phase = #f means not definite binding (ie, "?" arrow) - (send -text add-arrow - (+ start (car binder-r)) - (+ start (cdr binder-r)) - (+ start (car id-r)) - (+ start (cdr id-r)) - (if phase "blue" "purple") - (cond [(equal? phase 0) #f] - [phase (format "phase ~s" phase)] - [else "?"]) - (if phase 'end 'start))) - - (define/private (add-binding-billboard start range id definite?) - (match (identifier-binding id) - [(list-rest src-mod src-name nom-mod nom-name _) - (for ([id-r (in-list (send/i range range<%> get-ranges id))]) - (send -text add-billboard - (+ start (car id-r)) - (+ start (cdr id-r)) - (string-append "from " (mpi->string src-mod)) - (if definite? "blue" "purple")))] - [_ (void)])) - - (define/public (add-separator) - (with-unlock -text - (send* -text - (insert (new hrule-snip%)) - (insert "\n")))) - - (define/public (erase-all) - (with-unlock -text - (send -text erase)) - (send/i controller displays-manager<%> remove-all-syntax-displays)) - - (define/public (get-text) -text) - - (define/private (calculate-columns) - (define style (code-style -text (send/i config config<%> get-syntax-font-size))) - (define char-width (send style get-text-width (send -ecanvas get-dc))) - #| - (define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) - (sub1 (inexact->exact (floor (/ canvas-w char-width)))) - |# - (let ([admin (send -text get-admin)] - [w-box (box 0.0)]) - (send admin get-view #f #f w-box #f) - (sub1 (inexact->exact (floor (/ (unbox w-box) char-width)))))) - - ;; Initialize - (super-new) - (setup-keymap) - - (send/i config config<%> listen-props-shown? - (lambda (show?) - (show-props show?))) - (send/i config config<%> listen-props-percentage - (lambda (p) - (update-props-percentage p))) - (internal-show-props (send/i config config<%> get-props-shown?)))) - - -(define clickback-style - (let ([sd (new style-delta%)]) - (send sd set-delta 'change-toggle-underline) - (send sd set-delta-foreground "blue") - sd)) - -(define error-text-style - (let ([sd (new style-delta%)]) - (send sd set-delta 'change-italic) - (send sd set-delta-foreground "red") - sd)) diff --git a/collects/macro-debugger/view/debug.rkt b/collects/macro-debugger/view/debug.rkt @@ -1,32 +0,0 @@ -#lang racket/base -(require racket/pretty - racket/class - unstable/class-iop - "interfaces.rkt" - "debug-format.rkt" - "view.rkt") -(provide debug-file) - -(define (widget-mixin %) - (class % - (define/override (top-interaction-kw? x) - (eq? (syntax-e x) '#%top-interaction)) - (super-new))) - -(define stepper-frame% - (class macro-stepper-frame% - (define/override (get-macro-stepper-widget%) - (widget-mixin (super get-macro-stepper-widget%))) - (super-new))) - -(define (make-stepper) - (define director (new macro-stepper-director%)) - (send director new-stepper)) - -(define (debug-file file) - (let-values ([(events msg ctx) (load-debug-file file)]) - (pretty-print msg) - (pretty-print ctx) - (let* ([w (make-stepper)]) - (send/i w widget<%> add-trace events) - w))) diff --git a/collects/macro-debugger/view/frame.rkt b/collects/macro-debugger/view/frame.rkt @@ -1,279 +0,0 @@ -#lang racket/base -(require racket/class - racket/path - racket/gui/base - framework - unstable/class-iop - "interfaces.rkt" - "stepper.rkt" - (prefix-in sb: "../syntax-browser/embed.rkt") - (prefix-in sb: "../syntax-browser/interfaces.rkt") - unstable/gui/notify) -(provide macro-stepper-frame-mixin) - -(define-syntax override/return-false - (syntax-rules () - [(override/return-false m ...) - (begin (define/override (m) #f) ...)])) - -(define (macro-stepper-frame-mixin base-frame%) - (class* base-frame% (stepper-frame<%>) - (init-field config) - (init-field director) - (init-field (filename #f)) - - (define obsoleted? #f) - - (inherit get-area-container - get-size - 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/i config config<%> get-width)) - (height (send/i config 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")) - - ;; Grrr... we get a spurious on-size event sometime after the - ;; frame is created, probably when the window-manager gets around - ;; to doing something. Avoid unnecessary updates. - (define-values (w0 h0) (get-size)) - (define/override (on-size w h) - (send/i config config<%> set-width w) - (send/i config config<%> set-height h) - (unless (and (= w0 w) (= h0 h)) - (when (send/i config config<%> get-refresh-on-resize?) - (send/i widget widget<%> update/preserve-view))) - (set!-values (w0 h0) (values w h))) - - (define warning-panel - (new horizontal-panel% - (parent (get-area-container)) - (stretchable-height #f) - (style '(deleted)))) - - (define/public (get-macro-stepper-widget%) - macro-stepper-widget%) - - (define/i widget widget<%> - (new (get-macro-stepper-widget%) - (parent (get-area-container)) - (director director) - (config config))) - (define/i controller sb:controller<%> - (send/i widget widget<%> get-controller)) - - (define/public (get-widget) widget) - (define/public (get-controller) controller) - - (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 - - (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?) - - (define stepper-menu - (new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) - - (define/override (file-menu:between-save-as-and-print file-menu) - (super file-menu:between-save-as-and-print file-menu) - (new separator-menu-item% (parent file-menu)) - (new (get-menu-item%) - (label "Duplicate stepper") - (parent file-menu) - (callback (lambda _ (send/i widget widget<%> duplicate-stepper)))) - (new (get-menu-item%) - (label "Duplicate stepper (current term only)") - (parent file-menu) - (callback (lambda _ (send/i widget widget<%> show-in-new-frame)))) - (new separator-menu-item% (parent file-menu))) - - (menu-option/notify-box stepper-menu - "View syntax properties" - (get-field props-shown? config)) - - (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/i controller sb:controller<%> set-identifier=? p))))]) - (send/i controller sb:controller<%> listen-identifier=? - (lambda (name+func) - (send this-choice check - (eq? (car name+func) (car p))))))) - (sb:identifier=-choices))) - - (let ([identifier=? (send/i config config<%> get-identifier=?)]) - (when identifier=? - (let ([p (assoc identifier=? (sb:identifier=-choices))]) - (send/i controller sb:controller<%> set-identifier=? p)))) - - (new (get-menu-item%) - (label "Clear selection") - (parent stepper-menu) - (callback - (lambda _ (send/i controller sb:controller<%> - set-selected-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 "Remove selected term") - (parent stepper-menu) - (callback (lambda _ (send/i widget widget<%> remove-current-term)))) - (new (get-menu-item%) - (label "Reset mark numbering") - (parent stepper-menu) - (callback (lambda _ (send/i widget widget<%> reset-primary-partition)))) - (let ([extras-menu - (new (get-menu%) - (label "Extra options") - (parent stepper-menu))]) - (new checkable-menu-item% - (label "Always suffix marked identifiers") - (parent extras-menu) - (callback - (lambda (i e) - (send/i config config<%> set-suffix-option - (if (send i is-checked?) - 'always - 'over-limit)) - (send/i widget widget<%> update/preserve-view)))) - (menu-option/notify-box extras-menu - "Factor out common context?" - (get-field split-context? config)) - (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 - "Refresh on resize" - (get-field refresh-on-resize? config)) - (menu-option/notify-box extras-menu - "Close old stepper on Run" - (get-field close-on-reset-console? config)) - (menu-option/notify-box extras-menu - "Draw binding arrows" - (get-field draw-arrows? config)) - (menu-option/notify-box extras-menu - "Enable reader abbreviations" - (get-field pretty-abbrev? config)) - (menu-option/notify-box extras-menu - "Extra navigation" - (get-field extra-navigation? config))) - - ;; fixup-menu : menu -> void - ;; Delete separators at beginning/end and duplicates in middle - (define/private (fixup-menu menu) - (define items - (filter (lambda (i) (not (send i is-deleted?))) - (send menu get-items))) - (define (delete-seps-loop items) - (if (and (pair? items) (is-a? (car items) separator-menu-item%)) - (begin (send (car items) delete) - (delete-seps-loop (cdr items))) - items)) - (define (middle-loop items) - (cond - [(and (pair? items) (is-a? (car items) separator-menu-item%)) - (middle-loop (delete-seps-loop (cdr items)))] - [(pair? items) - (middle-loop (cdr items))] - [else null])) - (middle-loop (delete-seps-loop items)) - (delete-seps-loop (reverse items)) - (void)) - - (for ([menu (send (get-menu-bar) get-items)]) - (fixup-menu menu)) - (frame:remove-empty-menus this) - (frame:reorder-menus this))) - -;; 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))) diff --git a/collects/macro-debugger/view/hiding-panel.rkt b/collects/macro-debugger/view/hiding-panel.rkt @@ -1,339 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - racket/match - unstable/class-iop - "interfaces.rkt" - "../model/hiding-policies.rkt" - "../util/mpi.rkt" - unstable/gui/notify) -(provide macro-hiding-prefs-widget%) - -(define mode:disable "Disable") -(define mode:standard "Standard") -(define mode:custom "Custom ...") - -#| - -TODO - - - allow entry of more policies - - visual feedback on rules applying to selected identifier - (need to switch from list to editor) - -|# - -;; macro-hiding-prefs-widget% -(define macro-hiding-prefs-widget% - (class* object% (hiding-prefs<%>) - (init parent) - (init-field/i (stepper widget<%>)) - (init-field config) - - (define/public (get-policy) - (let ([mode (get-mode)]) - (cond [(not (macro-hiding-enabled?)) #f] - [(equal? mode mode:standard) standard-policy] - [(equal? mode mode:custom) (get-custom-policy)]))) - - (define/private (get-custom-policy) - (let ([hide-racket? (send box:hide-racket get-value)] - [hide-libs? (send box:hide-libs get-value)] - [hide-contracts? (send box:hide-contracts get-value)] - [hide-transformers? (send box:hide-phase1 get-value)] - [specialized-policies (get-specialized-policies)]) - (policy->predicate - `(custom ,hide-racket? - ,hide-libs? - ,hide-contracts? - ,hide-transformers? - ,specialized-policies)))) - - (define super-panel - (new vertical-panel% - (parent parent) - (stretchable-height #f))) - (define top-line-panel - (new horizontal-panel% - (parent super-panel) - (alignment '(left center)) - (stretchable-height #f))) - (define customize-panel - (new horizontal-panel% - (parent super-panel) - (stretchable-height #f) - (alignment '(left top)) - (style '(deleted)))) - (define left-pane - (new vertical-pane% - (parent customize-panel) - (stretchable-width #f) - (alignment '(left top)))) - (define right-pane - (new vertical-pane% - (parent customize-panel))) - - (define mode-selector - (choice/notify-box - top-line-panel - "Macro hiding: " - (list mode:disable mode:standard mode:custom) - (get-field macro-hiding-mode config))) - (define top-line-inner-panel - (new horizontal-panel% - (parent top-line-panel) - (alignment '(right center)) - (style '(deleted)))) - - (define/private (get-mode) - (send/i config config<%> get-macro-hiding-mode)) - - (define/private (macro-hiding-enabled?) - (let ([mode (get-mode)]) - (or (equal? mode mode:standard) - (and (equal? mode mode:custom) - (send box:hiding get-value))))) - - (define/private (ensure-custom-mode) - (unless (equal? (get-mode) mode:custom) - (send/i config config<%> set-macro-hiding-mode mode:custom))) - - (define/private (update-visibility) - (let ([customizing (equal? (get-mode) mode:custom)]) - (send top-line-panel change-children - (lambda (children) - (append (remq top-line-inner-panel children) - (if customizing (list top-line-inner-panel) null)))) - (send super-panel change-children - (lambda (children) - (append (remq customize-panel children) - (if (and customizing (send box:edit get-value)) - (list customize-panel) - null)))))) - - (send/i config config<%> listen-macro-hiding-mode - (lambda (value) - (update-visibility) - (force-refresh))) - - (define box:hiding - (new check-box% - (label "Enable macro hiding") - (value #t) - (parent top-line-inner-panel) - (callback (lambda (c e) (force-refresh))))) - (define box:edit - (new check-box% - (label "Show policy editor") - (parent top-line-inner-panel) - (value #t) - (callback (lambda (c e) (update-visibility))))) - - (define box:hide-racket - (new check-box% - (label "Hide racket syntax") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) - (define box:hide-libs - (new check-box% - (label "Hide library syntax") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) - (define box:hide-contracts - (new check-box% - (label "Hide contracts (heuristic)") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) - (define box:hide-phase1 - (new check-box% - (label "Hide phase>0") - (parent left-pane) - (value #t) - (callback (lambda (c e) (refresh))))) - - (define look-ctl - (new list-box% (parent right-pane) (label "") - (choices null) (style '(extended)) - (callback - (lambda (c e) - (send delete-ctl enable (pair? (send c get-selections))))))) - - (define look-button-pane - (new horizontal-pane% (parent right-pane) (stretchable-width #f))) - - (define delete-ctl - (new button% (parent look-button-pane) (label "Delete rule") (enabled #f) - (callback (lambda _ (delete-selected) (refresh))))) - (define add-hide-id-button - (new button% (parent look-button-pane) (label "Hide macro") (enabled #f) - (callback (lambda _ (add-hide-identifier) (refresh))))) - (define add-show-id-button - (new button% (parent look-button-pane) (label "Show macro") (enabled #f) - (callback (lambda _ (add-show-identifier) (refresh))))) - ;;(new grow-box-spacer-pane% (parent right-pane)) - - ;; Methods - - (define stx #f) - - ;; refresh : -> void - (define/public (refresh) - (when (macro-hiding-enabled?) - (send/i stepper widget<%> refresh/resynth))) - - ;; force-refresh : -> void - (define/private (force-refresh) - (send/i stepper widget<%> refresh/resynth)) - - ;; set-syntax : syntax/#f -> void - (define/public (set-syntax lstx) - (set! stx (and (identifier? lstx) lstx)) - (send add-show-id-button enable (identifier? lstx)) - (send add-hide-id-button enable (identifier? lstx))) - - ;; A PolicyLine is an Entry - ;; Entry is defined in ../model/hiding-policies - - ;; identifier-policies : (listof Entry) - (define identifier-policies null) - - ;; get-specialized-policies : -> (listof Entry) - (define/private (get-specialized-policies) - identifier-policies) - - (define/public (add-hide-identifier) - (when (identifier? stx) - (add-policy-line 'hide-if `(free=? ,stx)))) - - (define/public (add-show-identifier) - (when (identifier? stx) - (add-policy-line 'show-if `(free=? ,stx)))) - - ;; add-policy-line : 'show-if/'hide-if Condition -> void - (define/private (add-policy-line action condition) - (set! identifier-policies - (cons `(,action ,condition) - (remove-policy/condition condition identifier-policies))) - (update-list-view) - (ensure-custom-mode)) - - ;; update-list-view : -> void - (define/private (update-list-view) - (send look-ctl set null) - (for ([policy identifier-policies]) - (send look-ctl append (policy->string policy) policy))) - - ;; delete-selected : -> void - (define/private (delete-selected) - (define to-delete (sort (send look-ctl get-selections) <)) - (set! identifier-policies - (let loop ([i 0] [policies identifier-policies] [to-delete to-delete]) - (cond [(null? to-delete) policies] - [(= i (car to-delete)) - (loop (add1 i) (cdr policies) (cdr to-delete))] - [else - (cons (car policies) - (loop (add1 i) (cdr policies) to-delete))]))) - (update-list-view)) - - (super-new) - (update-visibility))) - - -(define (remove-policy/condition condition policies) - (filter (lambda (p) (not (same-condition? (cadr p) condition))) - policies)) - - -;; ---- - -(define (policy->string policy) - (string-limit 200 - (string-append - (case (car policy) - ((show-if) "show ") - ((hide-if) "hide ")) - (condition->string (cadr policy))))) - -(define (string-limit size s) - (cond [(> (string-length s) size) - (string-append (substring s 0 (- size 3)) "...")] - [else s])) - -(define (condition->string condition) - (match condition - [`(free=? ,id) - (let ([b (identifier-binding id)]) - (or #| (identifier->string id) |# - (cond [(list? b) - (let ([mod (caddr b)] - [name (cadddr b)]) - (if (self-mpi? mod) - (format "'~a' defined in this module" name) - (format "'~s' imported from ~a" name (mpi->string mod))))] - [else - (symbol->string (syntax-e id))])))] - [_ - "<condition>"])) - -#| -(require scribble/xref - scribble/manual-struct - setup/xref) - -(define xref-p (delay (load-collections-xref))) - -(define (identifier->string id) - (define binding-info (identifier-binding id)) - (define xref (force xref-p)) - (define definition-tag - (and xref - (xref-binding->definition-tag xref binding-info #f))) - (and definition-tag - (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) - (define index-entry - (and path (xref-tag->index-entry xref definition-tag))) - (define desc - (and index-entry (entry-desc index-entry))) - (and desc - (let ([name (exported-index-desc-name desc)] - [libs (exported-index-desc-from-libs desc)]) - (format "'~a' from ~a" - name - (mpi->string (car libs)))))))) -|# - - - -#| -(define (get-id-key id) - id - #; ;; FIXME - (let ([binding (identifier-binding id)]) - (get-id-key/binding id binding))) - -(define (get-id-key/binding id binding) - (cond [(pair? binding) - (list (car binding) (cadr binding))] - [else id])) - -(define (key=? key1 key2) - (cond [(and (identifier? key1) (identifier? key2)) - (free-identifier=? key1 key2)] - [(and (pair? key1) (pair? key2)) - (and (equal? (car key1) (car key2)) - (equal? (cadr key1) (cadr key2)))] - [else #f])) - -(define (key->text key) - (cond [(pair? key) - (let ([name (cadddr key)] - [mod (caddr key)]) - (format "'~s' from ~a" - name - (mpi->string mod)))] - [else (symbol->string (syntax-e key))])) -|# diff --git a/collects/macro-debugger/view/interfaces.rkt b/collects/macro-debugger/view/interfaces.rkt @@ -1,93 +0,0 @@ -#lang racket/base -(require unstable/class-iop - (prefix-in sb: "../syntax-browser/interfaces.rkt")) -(provide (all-defined-out)) - -(define-interface config<%> (sb:config<%>) - ((sb:methods:notify draw-arrows? - refresh-on-resize? - macro-hiding-mode - show-hiding-panel? - identifier=? - highlight-foci? - highlight-frontier? - show-rename-steps? - suppress-warnings? - one-by-one? - extra-navigation? - debug-catch-errors? - split-context?))) - -(define-interface widget<%> () - (get-config - get-controller - get-macro-hiding-prefs - get-step-displayer - - add-trace - add-deriv - - update/preserve-view - refresh/resynth - - reset-primary-partition - remove-current-term - duplicate-stepper - show-in-new-frame - - get-preprocess-deriv - get-show-macro? -)) - -(define-interface stepper-frame<%> () - (get-widget - get-controller - add-obsoleted-warning)) - -(define-interface hiding-prefs<%> () - (add-show-identifier - add-hide-identifier - set-syntax - get-policy - refresh)) - - -(define-interface step-display<%> () - (add-syntax - add-step - add-error - add-final - add-internal-error)) - - -(define-interface term-record<%> () - (get-raw-deriv - get-deriv-hidden? - get-step-index - get-step-count - invalidate-synth! - invalidate-steps! - - has-prev? - has-next? -#| - at-start? - at-end? -|# - navigate-to-start - navigate-to-end - navigate-previous - navigate-next - navigate-to - - on-get-focus - on-lose-focus - - display-initial-term - display-final-term - display-step - )) - -(define-interface director<%> () - (add-deriv - new-stepper)) diff --git a/collects/macro-debugger/view/step-display.rkt b/collects/macro-debugger/view/step-display.rkt @@ -1,269 +0,0 @@ -#lang racket/base -(require racket/class - racket/match - racket/gui/base - unstable/class-iop - "interfaces.rkt" - "../model/steps.rkt" - (prefix-in sb: "../syntax-browser/interfaces.rkt") - "debug-format.rkt") - -#; -(provide step-display% - step-display<%>) -(provide (all-defined-out)) -;; Struct for one-by-one stepping - -(define-struct (prestep protostep) ()) -(define-struct (poststep protostep) ()) - -(define (prestep-term1 s) (state-term (protostep-s1 s))) -(define (poststep-term2 s) (state-term (protostep-s1 s))) - -(define step-display% - (class* object% (step-display<%>) - - (init-field/i (config config<%>)) - (init-field ((sbview syntax-widget))) - (super-new) - - (define/public (add-internal-error part exn stx events) - (send/i sbview sb:syntax-browser<%> add-text - (string-append - (if (exn:break? exn) - "Macro stepper was interrupted" - "Macro stepper error") - (if part - (format " (~a)" part) - ""))) - (when (exn? exn) - (send/i sbview sb:syntax-browser<%> add-text " ") - (send/i sbview sb:syntax-browser<%> add-clickback "[details]" - (lambda _ (show-internal-error-details exn events)))) - (send/i sbview sb:syntax-browser<%> add-text ". ") - (when stx (send/i sbview sb:syntax-browser<%> add-text "Original syntax:")) - (send/i sbview sb:syntax-browser<%> add-text "\n") - (when stx (send/i sbview sb:syntax-browser<%> add-syntax stx))) - - (define/private (show-internal-error-details exn events) - (case (message-box/custom (if (exn:break? exn) - "Macro stepper was interrupted" - "Macro stepper internal error") - (format "Internal error:\n~a" (exn-message exn)) - "Show error" - "Dump debugging file" - "Cancel") - ((1) (queue-callback - (lambda () - (raise exn)))) - ((2) (queue-callback - (lambda () - (let ([file (put-file)]) - (when file - (write-debug-file file exn events)))))) - ((3 #f) (void)))) - - (define/public (add-error exn) - (send*/i sbview sb:syntax-browser<%> - (add-error-text (exn-message exn)) - (add-text "\n"))) - - (define/public (add-step step - #:shift-table [shift-table #f]) - (cond [(step? step) - (show-step step shift-table)] - [(misstep? step) - (show-misstep step shift-table)] - [(remarkstep? step) - (show-remarkstep step shift-table)] - [(prestep? step) - (show-prestep step shift-table)] - [(poststep? step) - (show-poststep step shift-table)])) - - (define/public (add-syntax stx - #:binders [binders '#hash()] - #:definites [definites #f] - #:shift-table [shift-table '#hash()]) - (send/i sbview sb:syntax-browser<%> add-syntax stx - #:binders binders - #:definites definites - #:shift-table shift-table)) - - (define/public (add-final stx error - #:binders binders - #:definites definites - #:shift-table [shift-table #f]) - (when stx - (send*/i sbview sb:syntax-browser<%> - (add-text "Expansion finished\n") - (add-syntax stx - #:binders binders - #:definites definites - #:shift-table shift-table))) - (when error - (add-error error))) - - ;; show-lctx : Step -> void - (define/private (show-lctx step shift-table) - (define state (protostep-s1 step)) - (define lctx (state-lctx state)) - (for ([bf lctx]) - (send/i sbview sb:syntax-browser<%> add-text - "\nwhile executing macro transformer in:\n") - (insert-syntax/redex (bigframe-term bf) - (bigframe-foci bf) - (state-binders state) - shift-table - (state-uses state) - (state-frontier state)))) - - ;; separator : Step [...] -> void - (define/private (separator step #:compact? [compact? #f]) - (insert-step-separator (step-type->string (protostep-type step)) - #:compact? compact?)) - - ;; show-step : Step -> void - (define/private (show-step step shift-table) - (let-values ([(common-context state1 state2) - (factor-common-context (protostep-s1 step) - (step-s2 step))]) - (show-state/redex state1 shift-table) - (separator step) - (show-state/contractum state2 shift-table) - (show-common-context common-context state1 shift-table) - (show-lctx step shift-table))) - - (define/private (factor-common-context state1 state2) - (if (send/i config config<%> get-split-context?) - (factor-common-context* state1 state2) - (values null state1 state2))) - - (define/private (factor-common-context* state1 state2) - (match-define - (struct state (e1 foci1 ctx1 lctx1 binders1 uses1 frontier1 seq1)) state1) - (match-define - (struct state (e2 foci2 ctx2 lctx2 binders2 uses2 frontier2 seq2)) state2) - (define (common xs ys acc) - (if (and (pair? xs) (pair? ys) (eq? (car xs) (car ys))) - (common (cdr xs) (cdr ys) (cons (car xs) acc)) - (values (reverse xs) (reverse ys) acc))) - (define-values (ctx1z ctx2z common-ctx) - (common (reverse ctx1) (reverse ctx2) null)) - (define state1z - (make-state e1 foci1 ctx1z lctx1 binders1 uses1 frontier1 seq1)) - (define state2z - (make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2)) - (values common-ctx state1z state2z)) - - (define/private (show-common-context ctx state1 shift-table) - (match-define - (struct state (_ _ _ _ _ uses1 frontier1 _)) state1) - (when (pair? ctx) - (let* ([hole-stx #'~~HOLE~~] - [the-syntax (context-fill ctx hole-stx)]) - (send*/i sbview sb:syntax-browser<%> - (add-text "\nin context:\n") - (add-syntax the-syntax - #:definites uses1 - #:binders (state-binders state1) - #:shift-table shift-table - #:substitutions (list (cons hole-stx "[ HOLE ]"))))))) - - (define/private (show-state/redex state shift-table) - (insert-syntax/redex (state-term state) - (state-foci state) - (state-binders state) - shift-table - (state-uses state) - (state-frontier state))) - - (define/private (show-state/contractum state shift-table) - (insert-syntax/contractum (state-term state) - (state-foci state) - (state-binders state) - shift-table - (state-uses state) - (state-frontier state))) - - ;; show-prestep : Step -> void - (define/private (show-prestep step shift-table) - (separator step #:compact? #t) - (show-state/redex (protostep-s1 step) shift-table) - (show-lctx step shift-table)) - - ;; show-poststep : Step -> void - (define/private (show-poststep step shift-table) - (separator step #:compact? #t) - (show-state/contractum (protostep-s1 step) shift-table) - (show-lctx step shift-table)) - - ;; show-misstep : Step -> void - (define/private (show-misstep step shift-table) - (define state (protostep-s1 step)) - (separator step #:compact? #t) - (send*/i sbview sb:syntax-browser<%> - (add-error-text (exn-message (misstep-exn step))) - (add-text "\n")) - (when (exn:fail:syntax? (misstep-exn step)) - (for ([e (exn:fail:syntax-exprs (misstep-exn step))]) - (send/i sbview sb:syntax-browser<%> add-syntax e - #:binders (state-binders state) - #:definites (state-uses state) - #:shift-table shift-table))) - (show-lctx step shift-table)) - - (define/private (show-remarkstep step shift-table) - (define state (protostep-s1 step)) - (for ([content (in-list (remarkstep-contents step))]) - (cond [(string? content) - (send*/i sbview sb:syntax-browser<%> - (add-text content) - (add-text "\n"))] - [(syntax? content) - (send*/i sbview sb:syntax-browser<%> - (add-syntax content - #:binders (state-binders state) - #:definites (state-uses state) - #:shift-table shift-table) - (add-text "\n"))])) - (show-lctx step shift-table)) - - ;; insert-syntax/color - (define/private (insert-syntax/color stx foci binders shift-table - definites frontier hi-color) - (define highlight-foci? (send/i config config<%> get-highlight-foci?)) - (define highlight-frontier? (send/i config config<%> get-highlight-frontier?)) - (send/i sbview sb:syntax-browser<%> add-syntax stx - #:definites definites - #:binders binders - #:shift-table shift-table - #:hi-colors (list hi-color - "WhiteSmoke") - #:hi-stxss (list (if highlight-foci? foci null) - (if highlight-frontier? frontier null)))) - - ;; insert-syntax/redex - (define/private (insert-syntax/redex stx foci binders shift-table - definites frontier) - (insert-syntax/color stx foci binders shift-table - definites frontier "MistyRose")) - - ;; insert-syntax/contractum - (define/private (insert-syntax/contractum stx foci binders shift-table - definites frontier) - (insert-syntax/color stx foci binders shift-table - definites frontier "LightCyan")) - - ;; insert-step-separator : string -> void - (define/private (insert-step-separator text #:compact? compact?) - (send*/i sbview sb:syntax-browser<%> - (add-text (if compact? "" "\n")) - (add-text - (make-object image-snip% - (build-path (collection-path "icons") - "red-arrow.bmp"))) - (add-text " [") - (add-text text) - (add-text "]\n\n"))) - )) diff --git a/collects/macro-debugger/view/stepper.rkt b/collects/macro-debugger/view/stepper.rkt @@ -1,578 +0,0 @@ -#lang racket/base -(require racket/class - racket/match - racket/gui/base - unstable/class-iop - "interfaces.rkt" - "extensions.rkt" - "hiding-panel.rkt" - "term-record.rkt" - "step-display.rkt" - (prefix-in sb: "../syntax-browser/interfaces.rkt") - "../model/deriv.rkt" - "../model/deriv-util.rkt" - "cursor.rkt" - "gui-util.rkt" - "../syntax-browser/util.rkt" - unstable/gui/notify - images/compile-time - images/gui - (for-syntax racket/base - images/icons/arrow images/icons/control images/logos - images/icons/style) - (only-in mzscheme [#%top-interaction mz-top-interaction])) -(provide macro-stepper-widget% - macro-stepper-widget/process-mixin) - -;; Compiled-in assets (button icons) - -(define navigate-up-icon - (compiled-bitmap (up-arrow-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) -(define navigate-to-start-icon - (compiled-bitmap (search-backward-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) -(define navigate-previous-icon - (compiled-bitmap (step-back-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) -(define navigate-next-icon - (compiled-bitmap (step-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) -(define navigate-to-end-icon - (compiled-bitmap (search-forward-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) -(define navigate-down-icon - (compiled-bitmap (down-arrow-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) - -(define small-logo (compiled-bitmap (macro-stepper-logo #:height 32))) -(define large-logo (compiled-bitmap (macro-stepper-logo))) - -(define (show-about-dialog parent) - (define dlg - (new logo-about-dialog% - (label "About the Macro Stepper") - (parent parent) - (bitmap large-logo) - (messages '("The Macro Stepper is formalized and proved correct in\n" - "\n" - " Ryan Culpepper and Matthias Felleisen\n" - " Debugging Hygienic Macros\n" - " Science of Computer Programming, July 2010\n")))) - (send dlg show #t)) - -;; Macro Stepper - -;; macro-stepper-widget% -(define macro-stepper-widget% - (class* object% (widget<%>) - (init-field parent) - (init-field config) - (init-field/i (director director<%>)) - - (define frame (send parent get-top-level-window)) - (define eventspace (send frame get-eventspace)) - - (define-syntax-rule (with-eventspace . body) - (parameterize ((current-eventspace eventspace)) - (queue-callback (lambda () . body)))) - - ;; Terms - - ;; all-terms : (list-of TermRecord) - ;; (Reversed) - (define all-terms null) - - ;; terms : (Cursor-of TermRecord) - ;; Contains visible terms of all-terms - (define terms (cursor:new null)) - - ;; focused-term : -> TermRecord or #f - (define (focused-term) - (cursor:next terms)) - - ;; current-step-index : notify of number/#f - (define-notify current-step-index (new notify-box% (value #f))) - - ;; add-deriv : Deriv -> void - (define/public (add-deriv d) - (let ([trec (new term-record% (stepper this) (raw-deriv d))]) - (add trec))) - - ;; add-trace : (list-of event) -> void - (define/public (add-trace events) - (let ([trec (new term-record% (stepper this) (events events))]) - (add trec))) - - ;; add : TermRecord -> void - (define/private (add trec) - (with-eventspace - (set! all-terms (cons trec all-terms)) - (let ([display-new-term? (cursor:at-end? terms)] - [invisible? (send/i trec term-record<%> get-deriv-hidden?)]) - (unless invisible? - (cursor:add-to-end! terms (list trec)) - (trim-navigator) - (if display-new-term? - (refresh) - (update)))))) - - ;; remove-current-term : -> void - (define/public (remove-current-term) - (when (cursor:has-next? terms) - (cursor:remove-current! terms) - (trim-navigator) - (refresh))) - - ;; show-in-new-frame : -> void - (define/public (show-in-new-frame) - (let ([term (focused-term)]) - (when term - (let ([new-stepper (send/i director director<%> new-stepper '(no-new-traces))]) - (send/i new-stepper widget<%> add-deriv (send/i term term-record<%> get-raw-deriv)) - (void))))) - - ;; duplicate-stepper : -> void - (define/public (duplicate-stepper) - (let ([new-stepper (send/i director director<%> new-stepper)]) - (for ([term (cursor->list terms)]) - (send/i new-stepper widget<%> add-deriv - (send/i term term-record<%> get-raw-deriv))))) - - (define/public (get-config) config) - (define/public (get-controller) sbc) - (define/public (get-view) sbview) - (define/public (get-step-displayer) step-displayer) - (define/public (get-macro-hiding-prefs) macro-hiding-prefs) - - (define/public (reset-primary-partition) - (send/i sbc sb:controller<%> reset-primary-partition) - (update/preserve-view)) - - (define superarea (new vertical-pane% (parent parent))) - (define area - (new vertical-panel% - (parent superarea) - (enabled #f))) - (define top-panel - (new horizontal-panel% - (parent area) - (horiz-margin 5) - (stretchable-height #f))) - (define supernavigator - (new horizontal-panel% - (parent top-panel) - (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 logo-canvas - (new (class bitmap-canvas% - (super-new (parent top-panel) (bitmap small-logo)) - (define/override (on-event evt) - (when (eq? (send evt get-event-type) 'left-up) - (show-about-dialog frame)))))) - - (define/i sbview sb:syntax-browser<%> - (new stepper-syntax-widget% - (parent area) - (macro-stepper this))) - (define/i step-displayer step-display<%> - (new step-display% - (config config) - (syntax-widget sbview))) - (define/i sbc sb:controller<%> - (send/i sbview sb:syntax-browser<%> get-controller)) - (define control-pane - (new vertical-panel% (parent area) (stretchable-height #f))) - - (define/i macro-hiding-prefs hiding-prefs<%> - (new macro-hiding-prefs-widget% - (parent control-pane) - (stepper this) - (config config))) - - (define status-area - (new status-area% - (parent superarea) - (stop-callback (lambda _ (stop-processing))))) - - (send/i sbc sb:controller<%> - listen-selected-syntax - (lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx))) - (send config listen-pretty-abbrev? - (lambda (_) (update/preserve-view))) - (send*/i config config<%> - (listen-show-hiding-panel? - (lambda (show?) (show-macro-hiding-panel show?))) - (listen-split-context? - (lambda (_) (update/preserve-view))) - (listen-highlight-foci? - (lambda (_) (update/preserve-view))) - (listen-highlight-frontier? - (lambda (_) (update/preserve-view))) - (listen-show-rename-steps? - (lambda (_) (refresh/re-reduce))) - (listen-one-by-one? - (lambda (_) (refresh/re-reduce))) - (listen-extra-navigation? - (lambda (show?) (show-extra-navigation show?)))) - (send config listen-pretty-styles - (lambda (_) (update/preserve-view))) - - (define nav:up - (new button% (label (list navigate-up-icon "Previous term" 'left)) (parent navigator) - (callback (lambda (b e) (navigate-up))))) - (define nav:start - (new button% (label (list navigate-to-start-icon "Start" 'left)) (parent navigator) - (callback (lambda (b e) (navigate-to-start))))) - (define nav:previous - (new button% (label (list navigate-previous-icon "Step" 'left)) (parent navigator) - (callback (lambda (b e) (navigate-previous))))) - (define nav:next - (new button% (label (list navigate-next-icon "Step" 'right)) (parent navigator) - (callback (lambda (b e) (navigate-next))))) - (define nav:end - (new button% (label (list navigate-to-end-icon "End" 'right)) (parent navigator) - (callback (lambda (b e) (navigate-to-end))))) - (define nav:down - (new button% (label (list navigate-down-icon "Next term" 'right)) (parent navigator) - (callback (lambda (b e) (navigate-down))))) - - (define nav:text - (new text-field% - (label "Step#") - (init-value "00000") - (parent extra-navigator) - (stretchable-width #f) - (stretchable-height #f) - (callback - (lambda (b e) - (when (eq? (send e get-event-type) 'text-field-enter) - (let* ([value (send b get-value)] - [step (string->number value)]) - (cond [(exact-positive-integer? step) - (navigate-to (sub1 step))] - [(equal? value "end") - (navigate-to-end)]))))))) - - (define nav:step-count - (new message% - (label "") - (parent extra-navigator) - (auto-resize #t) - (stretchable-width #f) - (stretchable-height #f))) - (send nav:text set-value "") - - (listen-current-step-index - (lambda (n) - (send nav:text set-value - (if (number? n) (number->string (add1 n)) "")))) - - (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-panel show?) - (send area change-children - (lambda (children) - (if show? - (append (remq control-pane children) (list control-pane)) - (remq control-pane children))))) - - (define/private (show-extra-navigation show?) - (send supernavigator change-children - (lambda (children) - (if show? - (list navigator extra-navigator) - (list navigator))))) - - (define/public (change-status msg) - (send status-area set-status msg)) - - ;; Navigation - (define/public-final (navigate-to-start) - (send/i (focused-term) term-record<%> navigate-to-start) - (update/preserve-lines-view)) - (define/public-final (navigate-to-end) - (send/i (focused-term) term-record<%> navigate-to-end) - (update/preserve-lines-view)) - (define/public-final (navigate-previous) - (send/i (focused-term) term-record<%> navigate-previous) - (update/preserve-lines-view)) - (define/public-final (navigate-next) - (send/i (focused-term) term-record<%> navigate-next) - (update/preserve-lines-view)) - (define/public-final (navigate-to n) - (send/i (focused-term) term-record<%> navigate-to n) - (update/preserve-lines-view)) - - (define/public-final (navigate-up) - (when (focused-term) - (send/i (focused-term) term-record<%> on-lose-focus)) - (cursor:move-prev terms) - (refresh/move)) - (define/public-final (navigate-down) - (when (focused-term) - (send/i (focused-term) term-record<%> on-lose-focus)) - (cursor:move-next terms) - (refresh/move)) - - ;; enable/disable-buttons : -> void - (define/private (enable/disable-buttons [? #t]) - (define term (and ? (focused-term))) - ;; (message-box "alert" (format "enable/disable: ~s" ?)) - (send area enable ?) - (send (send frame get-menu-bar) enable ?) - (send nav:start enable (and ? term (send/i term term-record<%> has-prev?))) - (send nav:previous enable (and ? term (send/i term term-record<%> has-prev?))) - (send nav:next enable (and ? term (send/i term term-record<%> has-next?))) - (send nav:end enable (and ? term (send/i term term-record<%> has-next?))) - (send nav:text enable (and ? term #t)) - (send nav:up enable (and ? (cursor:has-prev? terms))) - (send nav:down enable (and ? (cursor:has-next? terms))) - (send status-area enable-stop (not ?))) - - ;; Async update & refresh - - (define update-thread #f) - - (define ASYNC-DELAY 500) ;; milliseconds - - (define/private (call-with-update-thread thunk) - (send status-area set-visible #f) - (let* ([lock (make-semaphore 1)] ;; mutex for status variable - [status #f] ;; mutable: one of #f, 'done, 'async - [thd - (parameterize-break #f - (thread (lambda () - (with-handlers ([exn:break? - (lambda (e) - (change-status "Interrupted") - (void))]) - (parameterize-break #t - (thunk) - (change-status #f))) - (semaphore-wait lock) - (case status - ((async) - (set! update-thread #f) - (with-eventspace - (enable/disable-buttons #t))) - (else - (set! status 'done))) - (semaphore-post lock))))]) - (sync thd (alarm-evt (+ (current-inexact-milliseconds) ASYNC-DELAY))) - (semaphore-wait lock) - (case status - ((done) - ;; Thread finished; enable/disable skipped, so do it now to update. - (enable/disable-buttons #t)) - (else - (set! update-thread thd) - (send status-area set-visible #t) - (enable/disable-buttons #f) - (set! status 'async))) - (semaphore-post lock))) - - (define-syntax-rule (with-update-thread . body) - (call-with-update-thread (lambda () . body))) - - (define/private (stop-processing) - (let ([t update-thread]) - (when t (break-thread t)))) - - ;; Update - - ;; update/preserve-lines-view : -> void - (define/public (update/preserve-lines-view) - (with-update-thread - (define text (send/i sbview sb:syntax-browser<%> get-text)) - (define start-box (box 0)) - (define end-box (box 0)) - (send text get-visible-line-range start-box end-box) - (update*) - (send text scroll-to-position - (send text line-start-position (unbox start-box)) - #f - (send text line-start-position (unbox end-box)) - 'start))) - - ;; update/preserve-view : -> void - (define/public (update/preserve-view) - (with-update-thread - (define text (send/i sbview sb:syntax-browser<%> get-text)) - (define start-box (box 0)) - (define end-box (box 0)) - (send text get-visible-position-range start-box end-box) - (update*) - (send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))) - - ;; update : -> void - ;; Updates the terms in the syntax browser to the current step - (define/private (update) - (with-update-thread - (update*))) - - (define/private (update*) - ;; update:show-prefix : -> void - (define (update:show-prefix) - ;; Show the final terms from the cached synth'd derivs - (for ([trec (in-list (cursor:prefix->list terms))]) - (send/i trec term-record<%> display-final-term))) - ;; update:show-current-step : -> void - (define (update:show-current-step) - (when (focused-term) - (send/i (focused-term) term-record<%> display-step))) - ;; update:show-suffix : -> void - (define (update:show-suffix) - (let ([suffix0 (cursor:suffix->list terms)]) - (when (pair? suffix0) - (for ([trec (in-list (cdr suffix0))]) - (send/i trec term-record<%> display-initial-term))))) - ;; update-nav-index : -> void - (define (update-nav-index) - (define term (focused-term)) - (set-current-step-index - (and term (send/i term term-record<%> get-step-index)))) - - (define text (send/i sbview sb:syntax-browser<%> get-text)) - (define position-of-interest 0) - (define multiple-terms? (> (length (cursor->list terms)) 1)) - - (with-unlock text - (send/i sbview sb:syntax-browser<%> erase-all) - (update:show-prefix) - (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) - (set! position-of-interest (send text last-position)) - (update:show-current-step) - (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) - (update:show-suffix)) - - (send text scroll-to-position - position-of-interest - #f - (send text last-position) - 'start) - (update-nav-index) - (change-status #f)) - - ;; -- - - ;; refresh/resynth : -> void - ;; Macro hiding policy has changed; invalidate cached parts of trec - (define/public (refresh/resynth) - (for ([trec (in-list (cursor->list terms))]) - (send/i trec term-record<%> invalidate-synth!)) - (refresh)) - - ;; refresh/re-reduce : -> void - ;; Reduction config has changed; invalidate cached parts of trec - (define/private (refresh/re-reduce) - (for ([trec (in-list (cursor->list terms))]) - (send/i trec term-record<%> invalidate-steps!)) - (refresh)) - - ;; refresh/move : -> void - ;; Moving between terms; clear the saved position - (define/private (refresh/move) - (refresh)) - - ;; refresh : -> void - (define/public (refresh) - (with-update-thread - (when (focused-term) - (send/i (focused-term) term-record<%> on-get-focus)) - (send nav:step-count set-label "") - (let ([term (focused-term)]) - (when term - (let ([step-count (send/i term term-record<%> get-step-count)]) - (when step-count - ;; +1 for end of expansion "step" - (send nav:step-count set-label (format "of ~s" (add1 step-count))))))) - (update*))) - - ;; Hiding policy - - (define/public (get-show-macro?) - (send/i macro-hiding-prefs hiding-prefs<%> get-policy)) - - ;; Derivation pre-processing - - (define/public (get-preprocess-deriv) (lambda (d) d)) - - ;; Initialization - - (super-new) - (show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?)) - (show-extra-navigation (send/i config config<%> get-extra-navigation?)) - )) - -(define (macro-stepper-widget/process-mixin %) - (class % - (super-new) - (define/override (get-preprocess-deriv) - (lambda (d) (get-original-part d))) - - ;; get-original-part : Deriv -> Deriv/#f - ;; Strip off mzscheme's #%top-interaction - ;; Careful: the #%top-interaction node may be inside of a lift-deriv - (define/private (get-original-part deriv) - (let ([deriv* (adjust-deriv/lift deriv)]) - deriv*)) - - ;; adjust-deriv/lift : Deriv -> Deriv/#f - (define/private (adjust-deriv/lift deriv) - (match deriv - [(Wrap lift-deriv (e1 e2 first lifted-stx second)) - (let ([first (adjust-deriv/lift first)]) - (and first - (let ([e1 (wderiv-e1 first)]) - (make-lift-deriv e1 e2 first lifted-stx second))))] - [(Wrap ecte (e1 e2 '() first second locals2)) - ;; Only adjust if no locals... - (let ([first (adjust-deriv/lift first)]) - (and first - (let ([e1 (wderiv-e1 first)]) - (make ecte e1 e2 '() first second locals2))))] - [else (adjust-deriv/top deriv)])) - - ;; adjust-deriv/top : Derivation -> Derivation - (define/private (adjust-deriv/top deriv) - (if (or (not (base? deriv)) - (syntax-original? (wderiv-e1 deriv)) - (p:module? deriv)) - deriv - ;; It's not original... - ;; Strip out mzscheme's top-interactions - ;; Keep anything that is a non-mzscheme top-interaction - (cond [(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x)) - ;; Just mzscheme's top-interaction; strip it out - (adjust-deriv/top (mrule-next deriv))] - [else deriv]))) - - (define/public (top-interaction-kw? x) - (or (free-identifier=? x #'#%top-interaction) - (free-identifier=? x #'mz-top-interaction))) - - )) diff --git a/collects/macro-debugger/view/term-record.rkt b/collects/macro-debugger/view/term-record.rkt @@ -1,352 +0,0 @@ -#lang racket/base -(require racket/class - racket/match - syntax/stx - unstable/find - unstable/class-iop - "interfaces.rkt" - "step-display.rkt" - "../model/deriv.rkt" - "../model/deriv-util.rkt" - "../model/deriv-parser.rkt" - "../model/trace.rkt" - "../model/reductions-config.rkt" - "../model/reductions.rkt" - "../model/steps.rkt" - "cursor.rkt") - -(provide term-record%) - -;; TermRecords - -(define term-record% - (class* object% (term-record<%>) - (init-field/i (stepper widget<%>)) - - (define/i config config<%> - (send/i stepper widget<%> get-config)) - (define/i displayer step-display<%> - (send/i stepper widget<%> get-step-displayer)) - - ;; Data - - (init-field [events #f]) - - (init-field [raw-deriv #f]) - (define raw-deriv-oops #f) - - (define deriv #f) - (define deriv-hidden? #f) - (define shift-table #f) - - (define raw-steps #f) - (define raw-steps-estx #f) ;; #f if raw-steps-exn is exn - (define raw-steps-exn #f) ;; #f if raw-steps-estx is syntax - (define raw-steps-binders #f) - (define raw-steps-definites #f) - (define raw-steps-oops #f) - - (define steps #f) - - ;; -- - - (define steps-position #f) - - (define/private (status msg) - (send stepper change-status msg)) - (define-syntax-rule (with-status msg . body) - (begin (send stepper change-status msg) - (begin0 (let () . body)))) - - (super-new) - - (define-syntax define-guarded-getters - (syntax-rules () - [(define-guarded-getters guard (method expr) ...) - (begin (define/public (method) guard expr) ...)])) - - (define/public (get-events) events) - (define/public (get-raw-deriv) raw-deriv) - - (define-guarded-getters (recache-deriv!) - [get-deriv deriv] - [get-deriv-hidden? deriv-hidden?] - [get-shift-table shift-table]) - (define-guarded-getters (recache-raw-steps!) - [get-raw-steps-binders raw-steps-binders] - [get-raw-steps-definites raw-steps-definites] - [get-raw-steps-exn raw-steps-exn] - [get-raw-steps-oops raw-steps-oops]) - (define-guarded-getters (recache-steps!) - [get-steps steps]) - - ;; invalidate-steps! : -> void - ;; Invalidates cached parts that depend on reductions config - (define/public (invalidate-steps!) - (set! steps #f)) - - ;; invalidate-raw-steps! : -> void - (define/public (invalidate-raw-steps!) - (invalidate-steps!) - (set! raw-steps #f) - (set! raw-steps-estx #f) - (set! raw-steps-exn #f) - (set! raw-steps-binders #f) - (set! raw-steps-definites #f) - (set! raw-steps-oops #f)) - - ;; invalidate-synth! : -> void - ;; Invalidates cached parts that depend on macro-hiding policy - (define/public (invalidate-synth!) - (invalidate-raw-steps!)) - - ;; invalidate-deriv! : -> void - (define/public (invalidate-deriv!) - (invalidate-synth!) - (set! deriv #f) - (set! deriv-hidden? #f) - (set! shift-table #f)) - - ;; recache! : -> void - (define/public (recache!) - (recache-steps!)) - - ;; recache-raw-deriv! : -> void - (define/private (recache-raw-deriv!) - (unless (or raw-deriv raw-deriv-oops) - (with-handlers ([(lambda (e) #t) - (lambda (e) - (set! raw-deriv-oops e))]) - (with-status "Parsing expansion derivation" - (set! raw-deriv - (parse-derivation - (events->token-generator events))))))) - - ;; recache-deriv! : -> void - (define/private (recache-deriv!) - (unless (or deriv deriv-hidden?) - (recache-raw-deriv!) - (when raw-deriv - (with-status "Processing expansion derivation" - (let ([process (send/i stepper widget<%> get-preprocess-deriv)]) - (let ([d (process raw-deriv)]) - (when (not d) - (set! deriv-hidden? #t)) - (when d - (set! deriv d) - (set! shift-table (compute-shift-table d))))))))) - - ;; recache-synth! : -> void - (define/private (recache-synth!) - (recache-deriv!)) - - ;; recache-raw-steps! : -> void - (define/private (recache-raw-steps!) - (unless (or raw-steps raw-steps-oops) - (recache-synth!) - (when deriv - (with-status "Computing reduction steps" - (let ([show-macro? (or (send/i stepper widget<%> get-show-macro?) - (lambda (id) #t))]) - (with-handlers ([(lambda (e) #t) - (lambda (e) - (set! raw-steps-oops e))]) - (let-values ([(raw-steps* binders* definites* estx* error*) - (parameterize ((macro-policy show-macro?)) - (reductions+ deriv))]) - (set! raw-steps raw-steps*) - (set! raw-steps-estx estx*) - (set! raw-steps-exn error*) - (set! raw-steps-binders binders*) - (set! raw-steps-definites definites*)))))))) - - ;; recache-steps! : -> void - (define/private (recache-steps!) - (unless (or steps) - (recache-raw-steps!) - (when raw-steps - (with-status "Processing reduction steps" - (set! steps - (and raw-steps - (let* ([filtered-steps - (if (send/i config config<%> get-show-rename-steps?) - raw-steps - (filter (lambda (x) (not (rename-step? x))) - raw-steps))] - [processed-steps - (if (send/i config config<%> get-one-by-one?) - (reduce:one-by-one filtered-steps) - filtered-steps)]) - (cursor:new processed-steps)))) - (restore-position))))) - - ;; reduce:one-by-one : (list-of step) -> (list-of step) - (define/private (reduce:one-by-one rs) - (let loop ([rs rs]) - (match rs - [(cons (struct step (type s1 s2)) rs) - (list* (make prestep type s1) - (make poststep type s2) - (loop rs))] - [(cons (struct misstep (type s1 exn)) rs) - (list* (make misstep type s1 exn) - (loop rs))] - [(cons (and r (remarkstep type s1 contents)) rs) - (list* r (loop rs))] - ['() - null]))) - - ;; Navigation - - (define/public-final (has-prev?) - (and (get-steps) (not (cursor:at-start? (get-steps))))) - (define/public-final (has-next?) - (and (get-steps) (not (cursor:at-end? (get-steps))))) - - (define/public-final (get-step-index) - (let ([steps (get-steps)]) - (and steps (cursor-position steps)))) - (define/public-final (get-step-count) - (let ([steps (get-steps)]) - (and steps (cursor-count steps)))) - - (define/public-final (navigate-to-start) - (cursor:move-to-start (get-steps)) - (save-position)) - (define/public-final (navigate-to-end) - (cursor:move-to-end (get-steps)) - (save-position)) - (define/public-final (navigate-previous) - (cursor:move-prev (get-steps)) - (save-position)) - (define/public-final (navigate-next) - (cursor:move-next (get-steps)) - (save-position)) - (define/public-final (navigate-to n) - (cursor:skip-to (get-steps) n) - (save-position)) - - ;; save-position : -> void - (define/private (save-position) - (when (cursor? steps) - (let ([step (cursor:next steps)]) - (cond [(not step) - ;; At end; go to the end when restored - (set! steps-position +inf.0)] - [(protostep? step) - (set! steps-position - (extract-protostep-seq step))])))) - - ;; restore-position : number -> void - (define/private (restore-position) - (define (seek) - (let ([step (cursor:next steps)]) - (cond [(not step) - ;; At end; stop - (void)] - [(protostep? step) - (let ([step-pos (extract-protostep-seq step)]) - (cond [(not step-pos) - (cursor:move-next steps) - (seek)] - [(< step-pos steps-position) - (cursor:move-next steps) - (seek)] - [else (void)]))]))) - (when steps-position - (seek))) - - ;; extract-protostep-seq : step -> number/#f - (define/private (extract-protostep-seq step) - ;; FIXME: add back step numbers - (state-seq (protostep-s1 step))) - - ;; Warnings display - - ;; on-get-focus : -> void - (define/public (on-get-focus) - (recache-synth!)) - - ;; on-lose-focus : -> void - (define/public (on-lose-focus) - (when steps (cursor:move-to-start steps)) - (set! steps-position #f)) - - ;; Rendering - - ;; display-initial-term : -> void - (define/public (display-initial-term) - (with-status "Rendering term" - (cond [raw-deriv-oops - (send/i displayer step-display<%> add-internal-error - "derivation" raw-deriv-oops #f events)] - [else - (send/i displayer step-display<%> add-syntax (wderiv-e1 deriv))]))) - - ;; display-final-term : -> void - (define/public (display-final-term) - (recache-steps!) - (with-status "Rendering term" - (cond [(syntax? raw-steps-estx) - (send/i displayer step-display<%> add-syntax raw-steps-estx - #:binders raw-steps-binders - #:shift-table shift-table - #:definites raw-steps-definites)] - [(exn? raw-steps-exn) - (send/i displayer step-display<%> add-error raw-steps-exn)] - [else (display-oops #f)]))) - - ;; display-step : -> void - (define/public (display-step) - (recache-steps!) - (with-status "Rendering step" - (cond [steps - (let ([step (cursor:next steps)]) - (if step - (send/i displayer step-display<%> add-step step - #:shift-table shift-table) - (send/i displayer step-display<%> add-final raw-steps-estx raw-steps-exn - #:binders raw-steps-binders - #:shift-table shift-table - #:definites raw-steps-definites)))] - [else (display-oops #t)]))) - - ;; display-oops : boolean -> void - (define/private (display-oops show-syntax?) - (cond [raw-steps-oops - (send/i displayer step-display<%> add-internal-error - "steps" raw-steps-oops - (and show-syntax? (wderiv-e1 deriv)) - events)] - [raw-deriv-oops - (send/i displayer step-display<%> add-internal-error - "derivation" raw-deriv-oops #f events)] - [else - (error 'term-record::display-oops "internal error")])) - )) - - -;; compute-shift-table : deriv -> hash[id => (listof id)] -(define (compute-shift-table d) - (define ht (make-hasheq)) - (define module-forms - (find p:module? d #:stop-on-found? #t)) - (define module-shift-renamers - (for/list ([mf module-forms]) - (let ([shift (p:module-shift mf)] - [body (p:module-body mf)]) - (and shift body - (with-syntax ([(_module _name _lang shifted-body) shift]) - (add-rename-mapping ht (wderiv-e2 body) #'shifted-body)))))) - ht) - -(define (add-rename-mapping ht from to) - (define (loop from to) - (cond [(and (stx-pair? from) (stx-pair? to)) - (loop (stx-car from) (stx-car to)) - (loop (stx-cdr from) (stx-cdr to))] - [(and (identifier? from) (identifier? to)) - (hash-set! ht from (cons to (hash-ref ht from null)))] - [else (void)])) - (loop from to) - (void)) diff --git a/collects/tests/pkg/test-pkgs/pkg-z/info.rkt b/collects/tests/pkg/test-pkgs/pkg-z/info.rkt @@ -1,2 +0,0 @@ -#lang setup/infotab - diff --git a/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/info.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/info.rkt @@ -0,0 +1 @@ +#lang setup/infotab diff --git a/collects/macro-debugger/analysis/check-requires.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/analysis/check-requires.rkt diff --git a/collects/macro-debugger/analysis/private/get-references.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/get-references.rkt diff --git a/collects/macro-debugger/analysis/private/moduledb.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/moduledb.rkt diff --git a/collects/macro-debugger/analysis/private/nom-use-alg.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/nom-use-alg.rkt diff --git a/collects/macro-debugger/analysis/private/refine-alg.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/refine-alg.rkt diff --git a/collects/macro-debugger/analysis/private/util.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/util.rkt diff --git a/collects/macro-debugger/analysis/show-dependencies.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/analysis/show-dependencies.rkt diff --git a/collects/macro-debugger/expand.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/expand.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/info.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/info.rkt @@ -0,0 +1,11 @@ +#lang setup/infotab + +(define raco-commands + '(("check-requires" + (submod macro-debugger/analysis/check-requires main) + "check for useless requires" + #f) + ("show-dependencies" + (submod macro-debugger/analysis/show-dependencies main) + "show module dependencies" + #f))) diff --git a/collects/macro-debugger/model/context.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/context.rkt diff --git a/collects/macro-debugger/model/debug.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/debug.rkt diff --git a/collects/macro-debugger/model/deriv-c.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-c.rkt diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-parser.rkt diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-tokens.rkt diff --git a/collects/macro-debugger/model/deriv-util.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-util.rkt diff --git a/collects/macro-debugger/model/deriv.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/deriv.rkt diff --git a/collects/macro-debugger/model/hiding-policies.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/hiding-policies.rkt diff --git a/collects/macro-debugger/model/reductions-config.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/reductions-config.rkt diff --git a/collects/macro-debugger/model/reductions-engine.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/reductions-engine.rkt diff --git a/collects/macro-debugger/model/reductions.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/reductions.rkt diff --git a/collects/macro-debugger/model/steps.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/steps.rkt diff --git a/collects/macro-debugger/model/stx-util.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/stx-util.rkt diff --git a/collects/macro-debugger/model/trace.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/trace.rkt diff --git a/collects/macro-debugger/model/yacc-ext.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/yacc-ext.rkt diff --git a/collects/macro-debugger/model/yacc-interrupted.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/model/yacc-interrupted.rkt diff --git a/collects/macro-debugger/stepper-text.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/stepper-text.rkt diff --git a/collects/macro-debugger/syntax-browser/interfaces.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/syntax-browser/interfaces.rkt diff --git a/collects/macro-debugger/syntax-browser/partition.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/syntax-browser/partition.rkt diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/syntax-browser/pretty-helper.rkt diff --git a/collects/macro-debugger/util/eomap.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/util/eomap.rkt diff --git a/collects/macro-debugger/util/mpi.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/util/mpi.rkt diff --git a/collects/macro-debugger/util/stxobj.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/util/stxobj.rkt diff --git a/collects/macro-debugger/view/debug-format.rkt b/pkgs/macro-debugger-pkgs/macro-debugger-text-lib/macro-debugger/view/debug-format.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/info.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/info.rkt @@ -0,0 +1,4 @@ +#lang setup/infotab + +(define deps '("macro-debugger-text-lib")) +(define build-deps '("racket-doc")) diff --git a/collects/macro-debugger/emit.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/emit.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/info.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/info.rkt @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define scribblings '(("macro-debugger.scrbl" () (tool-library)))) diff --git a/collects/macro-debugger/macro-debugger.scrbl b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/macro-debugger.scrbl diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/model/trace-raw.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/model/trace-raw.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require racket/class + parser-tools/lex + macro-debugger/model/deriv-tokens + "../syntax-browser/frame.rkt") +(provide (all-defined-out)) + +(define current-expand-observe + (dynamic-require ''#%expobs 'current-expand-observe)) + +(define (go-trace sexpr) + (define events null) + (define pos 0) + (define browser (make-syntax-browser)) + (define (show sig+val) + (define sig (car sig+val)) + (define val (cdr sig+val)) + (define t (tokenize sig val pos)) + (send browser add-text + (format "Signal: ~s: ~s\n" + pos + (token-name (position-token-token t)))) + (when val + (send browser add-syntax + (datum->syntax #f val))) + (set! pos (add1 pos))) + (parameterize ((current-expand-observe + (lambda (sig val) + (define t (tokenize sig val pos)) + (set! events (cons (cons sig val) events)) + #;(show (cons sig val))))) + (expand sexpr) + (for-each show (reverse events)))) + diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/stepper.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/stepper.rkt @@ -0,0 +1,25 @@ +#lang racket/base +(require racket/class + racket/contract/base + unstable/class-iop + macro-debugger/model/trace + "view/interfaces.rkt" + "view/view.rkt") + +(define (create-stepper deriv) + (define director (new macro-stepper-director%)) + (define stepper (send/i director director<%> new-stepper)) + (send/i director director<%> add-deriv deriv) + (void)) + +(define (expand/step stx) + (create-stepper (trace stx))) + +(define (expand-module/step module-path) + (create-stepper (trace-module module-path))) + +(provide/contract + [expand/step + (-> syntax? void?)] + [expand-module/step + (-> module-path? void?)]) diff --git a/collects/macro-debugger/syntax-browser.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/controller.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/controller.rkt @@ -0,0 +1,70 @@ +#lang racket/base +(require racket/class + unstable/class-iop + macro-debugger/syntax-browser/interfaces + macro-debugger/syntax-browser/partition + unstable/gui/notify) +(provide controller%) + +;; displays-manager-mixin +(define displays-manager-mixin + (mixin () (displays-manager<%>) + ;; displays : (list-of display<%>) + (field [displays null]) + + ;; add-syntax-display : display<%> -> void + (define/public (add-syntax-display c) + (set! displays (cons c displays))) + + ;; remove-all-syntax-displays : -> void + (define/public (remove-all-syntax-displays) + (set! displays null)) + + (super-new))) + +;; selection-manager-mixin +(define selection-manager-mixin + (mixin (displays-manager<%>) (selection-manager<%>) + (inherit-field displays) + (define-notify selected-syntax (new notify-box% (value #f))) + + (super-new) + (listen-selected-syntax + (lambda (new-value) + (for-each (lambda (display) (send/i display display<%> refresh)) + displays))))) + +;; mark-manager-mixin +(define mark-manager-mixin + (mixin () (mark-manager<%>) + (init-field/i [primary-partition partition<%> (new-bound-partition)]) + (super-new) + + ;; get-primary-partition : -> partition + (define/public-final (get-primary-partition) + primary-partition) + + ;; reset-primary-partition : -> void + (define/public-final (reset-primary-partition) + (set! primary-partition (new-bound-partition))))) + +;; secondary-relation-mixin +(define secondary-relation-mixin + (mixin (displays-manager<%>) (secondary-relation<%>) + (inherit-field displays) + (define-notify identifier=? (new notify-box% (value #f))) + + (listen-identifier=? + (lambda (name+proc) + (for ([d (in-list displays)]) + (send/i d display<%> refresh)))) + (super-new))) + +(define controller% + (class* (secondary-relation-mixin + (selection-manager-mixin + (mark-manager-mixin + (displays-manager-mixin + object%)))) + (controller<%>) + (super-new))) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/display.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/display.rkt @@ -0,0 +1,418 @@ +#lang racket/base +(require racket/class + racket/gui/base + racket/promise + data/interval-map + framework + unstable/class-iop + "pretty-printer.rkt" + macro-debugger/syntax-browser/interfaces + "prefs.rkt" + "util.rkt" + "../util/logger.rkt") +(provide print-syntax-to-editor + code-style) + +(define-syntax-rule (uninterruptible e ...) + ;; (coarsely) prevent breaks within editor operations + (parameterize-break #f (begin e ...)) + #| + (parameterize-break #f + (let ([ta (now)]) + (begin0 (begin e ...) + (let ([tb (now)]) + (eprintf "****\n") + (pretty-write '(begin e ...) (current-error-port)) + (eprintf " -- ~s ms\n\n" (- tb ta)))))) + |#) + +(define (now) (current-inexact-milliseconds)) + +;; FIXME: assumes text never moves + +;; print-syntax-to-editor : syntax text controller<%> config number number +;; -> display<%> +;; Note: must call display<%>::refresh to finish styling. +(define (print-syntax-to-editor stx text controller config columns + [insertion-point (send text last-position)]) + (define output-port (open-output-string/count-lines)) + (define range + (with-log-time "** pretty-print-syntax" + (pretty-print-syntax stx output-port + (send/i controller controller<%> get-primary-partition) + (length (send/i config config<%> get-colors)) + (send/i config config<%> get-suffix-option) + (send config get-pretty-styles) + columns + (send config get-pretty-abbrev?)))) + (define output-string (get-output-string output-port)) + (define output-length (sub1 (string-length output-string))) ;; skip final newline + (log-macro-stepper-debug "size of pretty-printed text: ~s" output-length) + (with-log-time "fixup-parentheses" + (fixup-parentheses output-string range)) + (with-unlock text + (with-log-time "inserting pretty-printed text" + (uninterruptible + (send text insert output-length output-string insertion-point))) + (new display% + (text text) + (controller controller) + (config config) + (range range) + (start-position insertion-point) + (end-position (+ insertion-point output-length))))) + +;; display% +;; Note: must call refresh method to finish styling. +(define display% + (class* object% (display<%>) + (init-field/i [controller controller<%>] + [config config<%>] + [range range<%>]) + (init-field text + start-position + end-position) + + (define base-style + (code-style text (send/i config config<%> get-syntax-font-size))) + + ;; on-next-refresh : (listof (cons stx style-delta)) + ;; Styles to be applied on next refresh only. (eg, underline) + (define on-next-refresh null) + + ;; extra-styles : hash[stx => (listof style-delta)] + ;; Styles to be re-applied on every refresh. + (define extra-styles (make-hasheq)) + + ;; to-undo-styles : (listof (cons nat nat)) + ;; Ranges to unbold or unhighlight when selection changes. + ;; FIXME: ought to be managed by text:region-data (to auto-update ranges) + ;; until then, positions are relative + (define to-undo-styles null) + + ;; initialize : -> void + (define/private (initialize) + (with-log-time "changing base style" + (uninterruptible + (send text change-style base-style start-position end-position #f))) + (with-log-time "applying primary styles" + (uninterruptible (apply-primary-partition-styles))) + (with-log-time "adding clickbacks" + (uninterruptible (add-clickbacks)))) + + ;; add-clickbacks : -> void + (define/private (add-clickbacks) + (define mapping (send text get-region-mapping 'syntax)) + (define lazy-interval-map-init + (delay + (with-log-time "forcing clickback mapping" + (uninterruptible + (for ([range (send/i range range<%> all-ranges)]) + (let ([stx (range-obj range)] + [start (range-start range)] + [end (range-end range)]) + (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))) + (define (the-callback position) + (force lazy-interval-map-init) + (send/i controller selection-manager<%> set-selected-syntax + (interval-map-ref mapping position #f))) + (send text set-clickregion start-position end-position the-callback) + (send text set-clickregion start-position end-position the-callback 'right-down)) + + ;; refresh : -> void + ;; Clears all highlighting and reapplies all non-foreground styles. + (define/public (refresh) + (with-log-time "refresh" + (with-unlock text + (uninterruptible + (let ([undo-select/highlight-d (get-undo-select/highlight-d)]) + (for ([r (in-list to-undo-styles)]) + (send text change-style undo-select/highlight-d + (relative->text-position (car r)) + (relative->text-position (cdr r))))) + (set! to-undo-styles null)) + (uninterruptible + (for ([stx+delta (in-list on-next-refresh)]) + (for ([r (in-list (send/i range range<%> get-ranges (car stx+delta)))]) + (restyle-range r (cdr stx+delta) #f))) + (set! on-next-refresh null)) + (uninterruptible + (apply-extra-styles)) + (let ([selected-syntax + (send/i controller selection-manager<%> + get-selected-syntax)]) + (uninterruptible + (apply-secondary-relation-styles selected-syntax)) + (uninterruptible + (apply-selection-styles selected-syntax)))))) + + ;; get-range : -> range<%> + (define/public (get-range) range) + + ;; get-start-position : -> number + (define/public (get-start-position) start-position) + + ;; get-end-position : -> number + (define/public (get-end-position) end-position) + + ;; highlight-syntaxes : (list-of syntax) string -> void + (define/public (highlight-syntaxes stxs hi-color) + (let ([delta (highlight-style-delta hi-color)]) + (for ([stx (in-list stxs)]) + (hash-set! extra-styles stx + (cons delta (hash-ref extra-styles stx null)))))) + + ;; underline-syntaxes : (listof syntax) -> void + (define/public (underline-syntaxes stxs) + (for ([stx (in-list stxs)]) + (set! on-next-refresh + (cons (cons stx underline-d) on-next-refresh)))) + + ;; Primary styles + ;; (Done once on initialization, never repeated) + + ;; apply-primary-partition-styles : -> void + ;; Changes the foreground color according to the primary partition. + ;; Only called once, when the syntax is first drawn. + (define/private (apply-primary-partition-styles) + (define style-list (send text get-style-list)) + (define (color-style color) + (let ([delta (new style-delta%)]) + (send delta set-delta-foreground color) + (send style-list find-or-create-style base-style delta))) + (define color-styles + (list->vector + (map color-style + (map translate-color + (send/i config config<%> get-colors))))) + (define overflow-style (color-style (translate-color "darkgray"))) + (define color-partition + (send/i controller mark-manager<%> get-primary-partition)) + (define offset start-position) + ;; Optimization: don't call change-style when new style = old style + (let tr*loop ([trs (send/i range range<%> get-treeranges)] [old-style #f]) + (for ([tr trs]) + (define stx (treerange-obj tr)) + (define start (treerange-start tr)) + (define end (treerange-end tr)) + (define subs (treerange-subs tr)) + (define new-style + (primary-style stx color-partition color-styles overflow-style)) + (unless (eq? old-style new-style) + (send text change-style new-style (+ offset start) (+ offset end) #f)) + (tr*loop subs new-style))) + (void)) + + ;; primary-style : syntax partition (vector-of style-delta%) style-delta% + ;; -> style-delta% + (define/private (primary-style stx partition color-vector overflow) + (let ([n (send/i partition partition<%> get-partition stx)]) + (cond [(< n (vector-length color-vector)) + (vector-ref color-vector n)] + [else + overflow]))) + + ;; Secondary Styling + ;; May change in response to user actions + + ;; apply-extra-styles : -> void + ;; Applies externally-added styles (such as highlighting) + (define/private (apply-extra-styles) + (for ([(stx deltas) (in-hash extra-styles)]) + (for ([r (in-list (send/i range range<%> get-ranges stx))]) + (for ([delta (in-list deltas)]) + (restyle-range r delta #t))))) + + ;; apply-selection-styles : syntax -> void + ;; Styles subterms eq to the selected syntax + (define/private (apply-selection-styles selected-syntax) + (for ([r (in-list (send/i range range<%> get-ranges selected-syntax))]) + (restyle-range r select-d #t))) + + ;; apply-secondary-relation-styles : selected-syntax -> void + ;; If the selected syntax is an identifier, then styles all identifiers + ;; in the relation with it. + (define/private (apply-secondary-relation-styles selected-syntax) + (when (identifier? selected-syntax) + (let* ([name+relation + (send/i controller secondary-relation<%> + get-identifier=?)] + [relation (and name+relation (cdr name+relation))] + [secondary-highlight-d (get-secondary-highlight-d)]) + (when relation + (for ([id (in-list (send/i range range<%> get-identifier-list))]) + (when (relation selected-syntax id) + (for ([r (in-list (send/i range range<%> get-ranges id))]) + (restyle-range r secondary-highlight-d #t)))))))) + + ;; restyle-range : (cons num num) style-delta% boolean -> void + (define/private (restyle-range r style need-undo?) + (when need-undo? (set! to-undo-styles (cons r to-undo-styles))) + (send text change-style style + (relative->text-position (car r)) + (relative->text-position (cdr r)))) + + ;; relative->text-position : number -> number + (define/private (relative->text-position pos) + (+ pos start-position)) + + ;; Initialize + (super-new) + (send/i controller controller<%> add-syntax-display this) + (initialize))) + +;; fixup-parentheses : string range -> void +(define (fixup-parentheses string range) + (for ([r (send/i range range<%> all-ranges)]) + (let ([stx (range-obj r)] + [start (range-start r)] + [end (range-end r)]) + (when (and (syntax? stx) (pair? (syntax-e stx))) + (case (syntax-property stx 'paren-shape) + ((#\[) + (string-set! string start #\[) + (string-set! string (sub1 end) #\])) + ((#\{) + (string-set! string start #\{) + (string-set! string (sub1 end) #\}))))))) + +(define (open-output-string/count-lines) + (let ([os (open-output-string)]) + (port-count-lines! os) + os)) + +;; code-style : text<%> number/#f -> style<%> +(define (code-style text font-size) + (let* ([style-list (send text get-style-list)] + [style (send style-list find-named-style (editor:get-default-color-style-name))]) + (if font-size + (send style-list find-or-create-style + style + (make-object style-delta% 'change-size font-size)) + style))) + +;; anchor-snip% +(define anchor-snip% + (class snip% + (define/override (copy) + (make-object string-snip% "")) + (super-instantiate ()))) + +;; Color translation + +;; translate-color : color-string -> color% +(define (translate-color color-string) + (let ([c (make-object color% color-string)]) + (if (pref:invert-colors?) + (let-values ([(r* g* b*) + (lightness-invert (send c red) (send c green) (send c blue))]) + #| + (printf "translate: ~s -> ~s\n" + (list (send c red) (send c green) (send c blue)) + (list r* g* b*)) + |# + (make-object color% r* g* b*)) + c))) + +;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8) +(define (lightness-invert r g b) + (define (c x) + (/ (exact->inexact x) 255.0)) + (define (d x) + (inexact->exact (round (* x 255)))) + (let-values ([(r g b) (lightness-invert* (c r) (c g) (c b))]) + (values (d r) (d g) (d b)))) + +(define (lightness-invert* R G B) + (let-values ([(Hp Sl L) (rgb->hsl* R G B)]) + (hsl*->rgb Hp Sl (- 1.0 L)))) + +(define (rgb->hsl* R G B) + (define M (max R G B)) + (define m (min R G B)) + (define C (- M m)) + (define Hp + (cond [(zero? C) + ;; Undefined, but use 0 + 0.0] + [(= M R) + (realmod* (/ (- G B) C) 6)] + [(= M G) + (+ (/ (- B R) C) 2)] + [(= M B) + (+ (/ (- R G) C) 4)])) + (define L (* 0.5 (+ M m))) + (define Sl + (cond [(zero? C) 0.0] + [(>= L 0.5) (/ C (* 2 L))] + [else (/ C (- 2 (* 2 L)))])) + + (values Hp Sl L)) + +(define (hsl*->rgb Hp Sl L) + (define C + (cond [(>= L 0.5) (* 2 L Sl)] + [else (* (- 2 (* 2 L)) Sl)])) + (define X (* C (- 1 (abs (- (realmod Hp 2) 1))))) + (define-values (R1 G1 B1) + (cond [(< Hp 1) (values C X 0)] + [(< Hp 2) (values X C 0)] + [(< Hp 3) (values 0 C X)] + [(< Hp 4) (values 0 X C)] + [(< Hp 5) (values X 0 C)] + [(< Hp 6) (values C 0 X)])) + (define m (- L (* 0.5 C))) + (values (+ R1 m) (+ G1 m) (+ B1 m))) + +;; realmod : real integer -> real +;; Adjusts a real number to [0, base] +(define (realmod x base) + (define xint (ceiling x)) + (define m (modulo xint base)) + (realmod* (- m (- xint x)) base)) + +;; realmod* : real real -> real +;; Adjusts a number in [-base, base] to [0,base] +;; Not a real mod, but faintly reminiscent. +(define (realmod* x base) + (if (negative? x) + (+ x base) + x)) + +;; Styles + +(define select-d + (make-object style-delta% 'change-weight 'bold)) + +(define underline-d + (make-object style-delta% 'change-underline #t)) + +(define (highlight-style-delta raw-color #:translate-color? [translate-color? #t]) + (let ([sd (new style-delta%)] + [color (if translate-color? (translate-color raw-color) raw-color)]) + (send sd set-delta-background color) + sd)) + +(define (mk-2-constant-style bow-color [wob-color (translate-color bow-color)]) + (let ([wob-version (highlight-style-delta wob-color #:translate-color? #f)] + [bow-version (highlight-style-delta bow-color #:translate-color? #f)]) + (λ () + (if (pref:invert-colors?) + wob-version + bow-version)))) + +(define get-secondary-highlight-d + (mk-2-constant-style "yellow" "darkgoldenrod")) + +#| +(define undo-select-d + (make-object style-delta% 'change-weight 'normal)) +(define get-undo-highlight-d + (mk-2-constant-style "white" "black")) +|# + +(define (get-undo-select/highlight-d) + (let ([sd (make-object style-delta% 'change-weight 'normal)] + [bg (if (pref:invert-colors?) "black" "white")]) + (send sd set-delta-background bg) + sd)) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/embed.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/embed.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(require macro-debugger/syntax-browser/interfaces + "widget.rkt" + "keymap.rkt" + macro-debugger/syntax-browser/partition) + +(provide (all-from-out macro-debugger/syntax-browser/interfaces) + (all-from-out "widget.rkt") + (all-from-out "keymap.rkt") + identifier=-choices) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/frame.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/frame.rkt @@ -0,0 +1,97 @@ +#lang racket/base +(require racket/class + racket/gui/base + unstable/class-iop + macro-debugger/syntax-browser/interfaces + macro-debugger/syntax-browser/partition + "prefs.rkt" + "widget.rkt") +(provide browse-syntax + browse-syntaxes + make-syntax-browser + syntax-browser-frame% + syntax-widget/controls%) + +;; browse-syntax : syntax -> void +(define (browse-syntax stx) + (browse-syntaxes (list stx))) + +;; browse-syntaxes : (list-of syntax) -> void +(define (browse-syntaxes stxs) + (let ((w (make-syntax-browser))) + (for ([stx stxs]) + (send*/i w syntax-browser<%> + (add-syntax stx) + (add-separator))))) + +;; make-syntax-browser : -> syntax-browser<%> +(define (make-syntax-browser) + (let* ([view (new syntax-browser-frame%)]) + (send view show #t) + (send view get-widget))) + +;; syntax-browser-frame% +(define syntax-browser-frame% + (class* frame% () + (inherit get-width + get-height) + (init-field/i [config config<%> (new syntax-prefs%)]) + (super-new (label "Syntax Browser") + (width (send/i config config<%> get-width)) + (height (send/i config config<%> get-height))) + (define/i widget syntax-browser<%> + (new syntax-widget/controls% + (parent this) + (config config))) + (define/public (get-widget) widget) + (define/augment (on-close) + (send*/i config config<%> + (set-width (get-width)) + (set-height (get-height))) + (send widget shutdown) + (inner (void) on-close)))) + +;; syntax-widget/controls% +(define syntax-widget/controls% + (class* widget% () + (inherit get-main-panel + get-controller) + (super-new) + (inherit-field config) + + (define -control-panel + (new horizontal-pane% + (parent (get-main-panel)) + (stretchable-height #f))) + + ;; Put the control panel up front + (send (get-main-panel) change-children + (lambda (children) + (cons -control-panel (remq -control-panel children)))) + + (define -identifier=-choices (identifier=-choices)) + (define -choice + (new choice% (label "identifier=?") (parent -control-panel) + (choices (map car -identifier=-choices)) + (callback + (lambda (c e) + (send/i (get-controller) controller<%> set-identifier=? + (assoc (send c get-string-selection) + -identifier=-choices)))))) + (new button% + (label "Clear") + (parent -control-panel) + (callback (lambda _ (send/i (get-controller) controller<%> set-selected-syntax #f)))) + (new button% + (label "Properties") + (parent -control-panel) + (callback + (lambda _ + (send/i config config<%> set-props-shown? + (not (send/i config config<%> get-props-shown?)))))) + + (send/i (get-controller) controller<%> listen-identifier=? + (lambda (name+func) + (send -choice set-selection + (or (send -choice find-string (car name+func)) 0)))) + )) diff --git a/collects/macro-debugger/syntax-browser/hrule-snip.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/hrule-snip.rkt diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/image.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/keymap.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/keymap.rkt @@ -0,0 +1,125 @@ +#lang racket/base +(require racket/class + racket/gui/base + racket/pretty + unstable/gui/notify + macro-debugger/syntax-browser/interfaces) +(provide syntax-keymap%) + +(define keymap/popup% + (class* keymap% (keymap/popup<%>) + (init editor) + (super-new) + (inherit add-function + map-function + chain-to-keymap) + + (define/public (add-context-menu-items menu) + (void)) + + (map-function "rightbutton" "popup-context-menu") + (add-function "popup-context-menu" + (lambda (editor event) + (popup-context-menu editor event))) + + (define/private (popup-context-menu 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)) + (define menu (new popup-menu%)) + (add-context-menu-items menu) + (send admin popup-menu menu x y)) + + ;; FIXME: move out of constructor to use sites + (chain-to-keymap (send editor get-keymap) #t) + (send editor set-keymap this))) + +(define syntax-keymap% + (class keymap/popup% + (init-field controller + config) + (inherit add-function + map-function + call-function + chain-to-keymap) + (super-new) + + (define/private (selected-syntax) + (send controller get-selected-syntax)) + + ;; Functionality + + (add-function "copy-syntax-as-text" + (lambda (_ event) + (define stx (send controller get-selected-syntax)) + (when stx + (send the-clipboard set-clipboard-string + (let ([out (open-output-string)]) + (pretty-print (syntax->datum stx) out) + (get-output-string out)) + (send event get-time-stamp))))) + + (add-function "clear-syntax-selection" + (lambda (i e) + (send controller set-selected-syntax #f))) + + (add-function "show-syntax-properties" + (lambda (i e) + (send config set-props-shown? #t))) + + (add-function "hide-syntax-properties" + (lambda (i e) + (send config set-props-shown? #f))) + + (define ((pretty-print-as sym) i e) + (let ([stx (selected-syntax)]) + (when (identifier? stx) + (send config set-pretty-styles + (hash-set (send config get-pretty-styles) + (syntax-e stx) + sym))))) + + (define/override (add-context-menu-items menu) + (new menu-item% (label "Copy") (parent menu) + (demand-callback + (lambda (i) + (send i enable (and (selected-syntax) #t)))) + (callback + (lambda (i e) + (call-function "copy-syntax-as-text" i e)))) + (new separator-menu-item% (parent menu)) + (new menu-item% + (label "Clear selection") + (parent menu) + (demand-callback + (lambda (i) + (send i enable (and (selected-syntax) #t)))) + (callback + (lambda (i e) + (call-function "clear-syntax-selection" i e)))) + (menu-option/notify-box menu "View syntax properties" + (get-field props-shown? config)) + (let ([pretty-menu + (new menu% + (label "Change layout") + (parent menu) + (demand-callback + (lambda (i) + (send i enable (and (identifier? (selected-syntax)) #t)))))]) + (for ([sym+desc '((and "like and") + (begin "like begin (0 up)") + (lambda "like lambda (1 up)") + (do "like do (2 up)"))]) + (new menu-item% + (label (format "Format identifier ~a" (cadr sym+desc))) + (parent pretty-menu) + (demand-callback + (lambda (i) + (let ([stx (selected-syntax)]) + (when (identifier? stx) + (send i set-label + (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))) + (callback + (pretty-print-as (car sym+desc))))))))) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/prefs.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/prefs.rkt @@ -0,0 +1,87 @@ +#lang racket/base +(require racket/class + framework/preferences + macro-debugger/syntax-browser/interfaces + unstable/gui/notify + unstable/gui/prefs) +(provide prefs-base% + syntax-prefs-base% + syntax-prefs% + syntax-prefs/readonly% + + pref:invert-colors?) + +(preferences:set-default 'SyntaxBrowser:Width 700 number?) +(preferences:set-default 'SyntaxBrowser:Height 600 number?) +(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) +(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?) +(preferences:set-default 'SyntaxBrowser:DrawArrows? #t boolean?) + +(define pref:width (pref:get/set 'SyntaxBrowser:Width)) +(define pref:height (pref:get/set 'SyntaxBrowser:Height)) +(define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage)) +(define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown)) +(define pref:draw-arrows? (pref:get/set 'SyntaxBrowser:DrawArrows?)) + +(define pref:invert-colors? (pref:get/set 'framework:white-on-black?)) + +(define prefs-base% + (class object% + ;; suffix-option : SuffixOption + (define-notify suffix-option (new notify-box% (value 'over-limit))) + + ;; pretty-abbrev? : boolean + (define-notify pretty-abbrev? (new notify-box% (value #t))) + + ;; pretty-styles : ImmutableHash[symbol -> symbol] + (define-notify pretty-styles + (new notify-box% (value (make-immutable-hasheq null)))) + + ;; syntax-font-size : number/#f + ;; When non-false, overrides the default font size + (define-notify syntax-font-size (new notify-box% (value #f))) + + ;; colors : (listof string) + (define-notify colors + (new notify-box% (value the-colors))) + + (super-new))) + +(define alt-colors + '("black" + "red" "blue" "forestgreen" "purple" "brown" + "firebrick" "darkblue" "seagreen" "violetred" "chocolate" + "darkred" "cornflowerblue" "darkgreen" "indigo" "sandybrown" + "orange" "cadetblue" "olive" "mediumpurple" "goldenrod")) + +(define the-colors + '("black" "red" "blue" + "mediumforestgreen" "darkgreen" + "darkred" + "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue" + "indigo" "purple" + "orange" "salmon" "darkgoldenrod" "olive")) + +(define syntax-prefs-base% + (class* prefs-base% (config<%>) + (init readonly?) + + (define-syntax-rule (define-pref-notify* (name pref) ...) + (begin (define-notify name (notify-box/pref pref #:readonly? readonly?)) ...)) + + (define-pref-notify* + (width pref:width) + (height pref:height) + (props-percentage pref:props-percentage) + (props-shown? pref:props-shown?) + (draw-arrows? pref:draw-arrows?)) + + (super-new))) + +(define syntax-prefs% + (class syntax-prefs-base% + (super-new (readonly? #f)))) + +(define syntax-prefs/readonly% + (class syntax-prefs-base% + (super-new (readonly? #t)))) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/pretty-printer.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/pretty-printer.rkt @@ -0,0 +1,192 @@ +#lang racket/base +(require racket/class + racket/pretty + racket/gui/base + racket/promise + macro-debugger/syntax-browser/pretty-helper + macro-debugger/syntax-browser/interfaces) +(provide pretty-print-syntax) + +;; FIXME: Need to disable printing of structs with custom-write property + +;; pretty-print-syntax : syntax port partition number SuffixOption hasheq number bool +;; -> range% +(define (pretty-print-syntax stx port + primary-partition colors suffix-option styles columns abbrev?) + (define range-builder (new range-builder%)) + (define-values (datum ht:flat=>stx ht:stx=>flat) + (syntax->datum/tables stx primary-partition colors suffix-option abbrev?)) + (define identifier-list + (filter identifier? (hash-map ht:stx=>flat (lambda (k v) k)))) + (define (flat=>stx obj) + (hash-ref ht:flat=>stx obj #f)) + (define (stx=>flat stx) + (hash-ref ht:stx=>flat stx)) + (define (current-position) + (let-values ([(line column position) (port-next-location port)]) + (sub1 position))) + (define (pp-pre-hook obj port) + (when (flat=>stx obj) + (send range-builder push! (current-position))) + (send range-builder set-start obj (current-position))) + (define (pp-post-hook obj port) + (define stx (flat=>stx obj)) + (when stx + (send range-builder pop! stx (current-position))) + (let ([start (send range-builder get-start obj)] + [end (current-position)]) + (when (and start stx) + (send range-builder add-range stx (cons start end))))) + + (unless (syntax? stx) + (raise-type-error 'pretty-print-syntax "syntax" stx)) + (parameterize + ([pretty-print-pre-print-hook pp-pre-hook] + [pretty-print-post-print-hook pp-post-hook] + [pretty-print-size-hook pp-size-hook] + [pretty-print-print-hook pp-print-hook] + [pretty-print-remap-stylable pp-remap-stylable] + [pretty-print-abbreviate-read-macros abbrev?] + [pretty-print-current-style-table (pp-better-style-table styles)] + [pretty-print-columns columns]) + (pretty-print/defaults datum port) + (new range% + (range-builder range-builder) + (identifier-list identifier-list)))) + +(define (pp-print-hook obj display-like? port) + (cond [(syntax-dummy? obj) + ((if display-like? display write) (syntax-dummy-val obj) port)] + [(is-a? obj editor-snip%) + (write-special obj port)] + [else + (error 'pretty-print-hook "unexpected special value: ~e" obj)])) + +(define (pp-size-hook obj display-like? port) + (cond [(is-a? obj editor-snip%) + (pretty-print-columns)] + [(syntax-dummy? obj) + (let ((ostring (open-output-string))) + ((if display-like? display write) (syntax-dummy-val obj) ostring) + (string-length (get-output-string ostring)))] + [else #f])) + +(define (pp-remap-stylable obj) + (and (id-syntax-dummy? obj) + (let ([remap (id-syntax-dummy-remap obj)]) + (and (not (memq remap special-expression-keywords)) + remap)))) + +(define (pp-better-style-table styles) + (define style-list (for/list ([(k v) (in-hash styles)]) (cons k v))) + (pretty-print-extend-style-table + (basic-style-list) + (map car style-list) + (map cdr style-list))) + +(define (basic-style-list) + (pretty-print-extend-style-table + (pretty-print-current-style-table) + (map car basic-styles) + (map cdr basic-styles))) +(define basic-styles + '((define-values . define) + (define-syntaxes . define-syntax) + (define-for-syntax . define) + (define-values-for-syntax . define)) + #| + ;; Messes up formatting too much :( + (let* ([pref (pref:tabify)] + [table (car pref)] + [begin-rx (cadr pref)] + [define-rx (caddr pref)] + [lambda-rx (cadddr pref)]) + (let ([style-list (hash-table-map table cons)]) + (pretty-print-extend-style-table + (basic-style-list) + (map car style-list) + (map cdr style-list)))) + |#) + +(define-local-member-name range:get-ranges) + +;; range-builder% +(define range-builder% + (class object% + (define starts (make-hasheq)) + (define ranges (make-hasheq)) + + (define/public (set-start obj n) + (hash-set! starts obj n)) + + (define/public (get-start obj) + (hash-ref starts obj #f)) + + (define/public (add-range obj range) + (hash-set! ranges obj (cons range (get-ranges obj)))) + + (define (get-ranges obj) + (hash-ref ranges obj null)) + + (define/public (range:get-ranges) ranges) + + ;; ---- + + (define/public (get-subs) + working-subs) + + (define working-start #f) + (define working-subs null) + (define saved-starts null) + (define saved-subss null) + + (define/public (push! start) + (set! saved-starts (cons working-start saved-starts)) + (set! saved-subss (cons working-subs saved-subss)) + (set! working-start start) + (set! working-subs null)) + + (define/public (pop! stx end) + (define latest (make-treerange stx working-start end (reverse working-subs))) + (set! working-start (car saved-starts)) + (set! working-subs (car saved-subss)) + (set! saved-starts (cdr saved-starts)) + (set! saved-subss (cdr saved-subss)) + (set! working-subs (cons latest working-subs))) + + (super-new))) + +;; range% +(define range% + (class* object% (range<%>) + (init range-builder) + (init-field identifier-list) + (super-new) + + (define ranges (hash-copy (send range-builder range:get-ranges))) + (define subs (reverse (send range-builder get-subs))) + + (define/public (get-ranges obj) + (hash-ref ranges obj null)) + + (define/public (get-treeranges) + subs) + + (define/public (all-ranges) + (force sorted-ranges)) + + (define/public (get-identifier-list) + identifier-list) + + (define sorted-ranges + (delay + (sort + (apply append + (hash-map + ranges + (lambda (k vs) + (map (lambda (v) (make-range k (car v) (cdr v))) vs)))) + (lambda (x y) + (>= (- (range-end x) (range-start x)) + (- (range-end y) (range-start y))))))) + )) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/properties.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/properties.rkt @@ -0,0 +1,356 @@ +#lang racket/base +(require racket/class + racket/match + racket/gui/base + framework + unstable/class-iop + macro-debugger/syntax-browser/interfaces + "util.rkt" + macro-debugger/util/mpi + macro-debugger/util/stxobj) +(provide properties-view% + properties-snip%) + +(define color-text-default-style-name + "macro-debugger/syntax-browser/properties color-text% basic") + +(define color-text% + (class (editor:standard-style-list-mixin text:basic%) + (inherit get-style-list) + (define/override (default-style-name) + color-text-default-style-name) + (super-new) + (let* ([sl (get-style-list)] + [standard + (send sl find-named-style (editor:get-default-color-style-name))] + [basic + (send sl find-or-create-style standard + (make-object style-delta% 'change-family 'default))]) + (send sl new-named-style color-text-default-style-name basic)))) + +;; properties-view-base-mixin +(define properties-view-base-mixin + (mixin () () + ;; controller : controller<%> + (init-field controller) + + ;; selected-syntax : syntax + (field (selected-syntax #f)) + + ;; mode : maybe symbol in '(term stxobj) + (define mode 'term) + + ;; text : text% + (field (text (new color-text%))) + (field (pdisplayer (new properties-displayer% (text text)))) + + (send/i controller selection-manager<%> listen-selected-syntax + (lambda (stx) + (set! selected-syntax stx) + (refresh))) + (super-new) + + ;; get-mode : -> symbol + (define/public (get-mode) mode) + + ;; set-mode : symbol -> void + (define/public (set-mode m) + (set! mode m) + (refresh)) + + ;; refresh : -> void + (define/public (refresh) + (with-unlock text + (send text erase) + (if (syntax? selected-syntax) + (refresh/mode mode) + (refresh/mode #f))) + (send text scroll-to-position 0)) + + ;; refresh/mode : symbol -> void + (define/public (refresh/mode mode) + (case mode + ((term) (send pdisplayer display-meaning-info selected-syntax)) + ((stxobj) (send pdisplayer display-stxobj-info selected-syntax)) + ((#f) (send pdisplayer display-null-info)) + (else (error 'properties-view-base:refresh + "internal error: no such mode: ~s" mode)))) + + (send text set-styles-sticky #f) + #;(send text hide-caret #t) + (send text lock #t) + (refresh))) + + +;; properties-snip% +(define properties-snip% + (class (properties-view-base-mixin editor-snip%) + (inherit-field text) + (inherit-field pdisplayer) + (inherit set-mode) + + (define/private outer:insert + (case-lambda + [(obj) + (outer:insert obj style:normal)] + [(text style) + (outer:insert text style #f)] + [(text style clickback) + (let ([start (send outer-text last-position)]) + (send outer-text insert text) + (let ([end (send outer-text last-position)]) + (send outer-text change-style style start end #f) + (when clickback + (send outer-text set-clickback start end clickback))))])) + + (define outer-text (new text%)) + (super-new (editor outer-text)) + (outer:insert "Term" style:hyper (lambda _ (set-mode 'term))) + (outer:insert " ") + (outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj))) + (outer:insert "\n") + (outer:insert (new editor-snip% (editor text))) + (send outer-text hide-caret #t) + (send outer-text lock #t))) + +;; properties-view% +(define properties-view% + (class* (properties-view-base-mixin object%) () + (init parent) + (inherit-field text) + (inherit-field pdisplayer) + (inherit set-mode) + + ;; get-tab-choices : (listof (cons string thunk)) + ;; Override to add or remove panels + (define/public (get-tab-choices) + (list (cons "Term" 'term) + (cons "Syntax Object" 'stxobj))) + + (super-new) + (define tab-choices (get-tab-choices)) + (define tab-panel + (new tab-panel% + (choices (map car tab-choices)) + (parent parent) + (callback + (lambda (tp e) + (set-mode (cdr (list-ref tab-choices (send tp get-selection)))))))) + (define ecanvas (new canvas:color% (editor text) (parent tab-panel))))) + +;; properties-displayer% +(define properties-displayer% + (class* object% () + (init-field text) + + ;; display-null-info : -> void + (define/public (display-null-info) + (display "No syntax selected\n" n/a-sd)) + + ;; display-meaning-info : syntax -> void + (define/public (display-meaning-info stx) + (when (and (identifier? stx) + (uninterned? (syntax-e stx))) + (display "Uninterned symbol!\n\n" key-sd)) + (display-binding-info stx) + (display-indirect-binding-info stx)) + + ;; display-binding-info : syntax -> void + (define/private (display-binding-info stx) + (display "Apparent identifier binding\n" key-sd) + (display-bindings stx)) + + ;; display-indirect-binding-info : syntax -> void + (define/private (display-indirect-binding-info stx) + (cond + [(identifier? stx) + (display "Binding if used for #%top\n" key-sd) + (display-bindings (datum->syntax stx '#%top))] + [(and (syntax? stx) (pair? (syntax-e stx))) + (display "Binding if used for #%app\n" key-sd) + (display-bindings (datum->syntax stx '#%app))] + [else + (display "Binding if used for #%datum\n" key-sd) + (display-bindings (datum->syntax stx '#%datum))])) + + ;; display-bindings : syntax -> void + (define/private (display-bindings stx) + (define phases-to-search '(0 1 -1 #f 2 3 4 5 -2 -3 -4 -5)) + (unless (identifier? stx) + (display "Not applicable\n\n" n/a-sd)) + (when (identifier? stx) + (cond [(eq? (identifier-binding stx) 'lexical) + (display "lexical (all phases)\n" #f)] + [else + (let ([bindings (for/hash ([phase (in-list phases-to-search)]) + (values phase (identifier-binding stx phase)))]) + (cond [(for/or ([(p b) (in-hash bindings)]) b) + (for ([phase (in-list phases-to-search)]) + (display-binding-kvs phase (hash-ref bindings phase #f) stx))] + [else (display "none\n" #f)]))]) + (display "\n" #f))) + + ;; display-binding-kvs : phase bindinginfo identifier -> void + (define/private (display-binding-kvs phase v stx) + (when v + (display (format "in phase ~a~a:" + phase + (case phase + ((1) " (transformer phase)") + ((-1) " (template phase)") + ((#f) " (label phase)") + (else ""))) + sub-key-sd) + (display "\n" #f) + (match v + [(list* def-mpi def-sym imp-mpi imp-sym defined-at-phase _) + (display-subkv " defined in" (mpi->string def-mpi)) + (unless (eq? def-sym (syntax-e stx)) + (display-subkv " as" def-sym)) + (display-subkv " imported from" (mpi->string imp-mpi)) + (unless (eq? imp-sym (syntax-e stx)) + (display-subkv " provided as" (list-ref v 3))) + (unless (zero? defined-at-phase) + (display-subkv " defined at phase" defined-at-phase))] + [_ (void)]))) + + ;; display-stxobj-info : syntax -> void + (define/public (display-stxobj-info stx) + (display-source-info stx) + (display-extra-source-info stx) + (display-symbol-property-info stx) + (display-marks stx) + ;; Disable until correct: + (when #f (display-taint stx))) + + ;; display-source-info : syntax -> void + (define/private (display-source-info stx) + (define s-source (syntax-source stx)) + (define s-line (syntax-line stx)) + (define s-column (syntax-column stx)) + (define s-position (syntax-position stx)) + (define s-span (syntax-span stx)) + (define s-span-known? (not (memv s-span '(0 #f)))) + (display "Source location\n" key-sd) + (if (or s-source s-line s-column s-position s-span-known?) + (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-span)) + (display "No source location available\n" n/a-sd)) + (display "\n" #f)) + + ;; display-extra-source-info : syntax -> void + (define/private (display-extra-source-info stx) + (display "Built-in properties\n" key-sd) + (display-subkv "source module" + (let ([mod (syntax-source-module stx)]) + (and mod (mpi->string mod)))) + (display-subkv "original?" (syntax-original? stx)) + (display "\n" #f)) + + ;; display-symbol-property-info : syntax -> void + (define/private (display-symbol-property-info stx) + (let ([keys (syntax-property-symbol-keys stx)]) + (display "Additional properties\n" key-sd) + (when (null? keys) + (display "No additional properties available.\n" n/a-sd)) + (when (pair? keys) + (for-each (lambda (k) (display-subkv/value k (syntax-property stx k))) + keys)) + (display "\n" #f))) + + ;; display-marks : syntax -> void + (define/private (display-marks stx) + (display "Marks: " key-sd) + (display (format "~s\n" (get-marks stx)) #f) + (display "\n" #f)) + + ;; display-taint : syntax -> void + (define/private (display-taint stx) + (define (syntax-armed? stx) + (syntax-tainted? (datum->syntax stx 'dummy))) + (display "Tamper status: " key-sd) + (display (cond [(syntax-tainted? stx) + "tainted"] + [(syntax-armed? stx) + "armed"] + [else "clean"]) + #f)) + + ;; display-kv : any any -> void + (define/private (display-kv key value) + (display (format "~a\n" key) key-sd) + (display (format "~s\n\n" value) #f)) + + ;; display-subkv : any any -> void + (define/public (display-subkv k v) + (display (format "~a: " k) sub-key-sd) + (display (format "~a\n" v) #f)) + + (define/public (display-subkv/value k v) + (display-subkv k v) + #; + (begin + (display (format "~a:\n" k) sub-key-sd) + (let* ([value-text (new text:standard-style-list% (auto-wrap #t))] + [value-snip (new editor-snip% (editor value-text))] + [value-port (make-text-port value-text)]) + (set-interactive-write-handler value-port) + (set-interactive-print-handler value-port) + (set-interactive-display-handler value-port) + (write v value-port) + (send value-text lock #t) + (send text insert value-snip) + (send text insert "\n") + #;(send ecanvas add-wide-snip value-snip)))) + + ;; display : string style-delta -> void + (define/private (display item sd) + (let ([p0 (send text last-position)]) + (send text insert item) + (let ([p1 (send text last-position)]) + (send text change-style sd p0 p1)))) + + (super-new))) + + +;; lift/id : (identifier -> void) 'a -> void +(define (lift/id f) + (lambda (stx) (when (identifier? stx) (f stx)))) + +(define (uninterned? s) + (not (eq? s (string->symbol (symbol->string s))))) + +(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") + (send sd set-weight-on 'bold) + sd)) + +(define sub-key-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "blue") + sd)) + +(define n/a-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "gray") + sd)) + +(define style:normal (make-object style-delta% 'change-normal)) + +(define style:hyper + (let ([s (make-object style-delta% 'change-normal)]) + (send s set-delta 'change-toggle-underline) + (send s set-delta-foreground "blue") + s)) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/snip-decorated.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/snip-decorated.rkt @@ -0,0 +1,208 @@ +#lang racket/base +(require racket/class + racket/gui/base + (only-in mzlib/string read-from-string) + unstable/class-iop + macro-debugger/syntax-browser/interfaces + "controller.rkt" + "properties.rkt" + "prefs.rkt" + "util.rkt" + (except-in "snip.rkt" + snip-class)) + +(provide decorated-syntax-snip% + snip-class) + +(define top-aligned + (make-object style-delta% 'change-alignment 'top)) + +(define-struct styled (contents style clickback)) + +;; clicky-snip% +(define clicky-snip% + (class* editor-snip% () + + (init-field [open-style '(border)] + [closed-style '(tight-text-fit)]) + + (inherit set-margin + set-inset + set-snipclass + set-tight-text-fit + show-border + get-admin) + + (define -outer (new text%)) + (super-new (editor -outer) (with-border? #f)) + (set-margin 2 2 2 2) + (set-inset 2 2 2 2) + ;;(set-margin 3 0 0 0) + ;;(set-inset 1 0 0 0) + ;;(set-margin 0 0 0 0) + ;;(set-inset 0 0 0 0) + + (define/public (closed-contents) null) + (define/public (open-contents) null) + + (define open? #f) + + (define/public (refresh-contents) + (with-unlock -outer + (send -outer erase) + (do-style (if open? open-style closed-style)) + (outer:insert (if open? (hide-icon) (show-icon)) + style:hyper + (if open? + (lambda _ + (set! open? #f) + (refresh-contents)) + (lambda _ + (set! open? #t) + (refresh-contents)))) + (for-each (lambda (s) (outer:insert s)) + (if open? (open-contents) (closed-contents))) + (send -outer change-style top-aligned 0 (send -outer last-position)))) + + (define/private (do-style style) + (show-border (memq 'border style)) + (set-tight-text-fit (memq 'tight-text-fit style))) + + (define/private outer:insert + (case-lambda + [(obj) + (if (styled? obj) + (outer:insert (styled-contents obj) + (styled-style obj) + (styled-clickback obj)) + (outer:insert obj style:normal))] + [(text style) + (outer:insert text style #f)] + [(text style clickback) + (let ([start (send -outer last-position)]) + (send -outer insert text) + (let ([end (send -outer last-position)]) + (send -outer change-style style start end #f) + (when clickback + (send -outer set-clickback start end clickback))))])) + + (send -outer hide-caret #t) + (send -outer lock #t) + (refresh-contents) + )) + +;; decorated-syntax-snip% +(define decorated-syntax-snip% + (class* clicky-snip% (readable-snip<%>) + (init-field ((stx syntax))) + (init-field [controller (new controller%)]) + (init-field [config (new syntax-prefs%)]) + + (inherit set-snipclass + refresh-contents) + + (define the-syntax-snip + (new syntax-snip% + (syntax stx) + (controller controller) + (config config))) + (define the-summary + (let* ([t (new text%)] + [es (new editor-snip% (editor t) (with-border? #f))]) + (send es set-margin 0 0 0 0) + (send es set-inset 0 0 0 0) + (send t insert (format "~s" stx)) + es)) + + (define properties-snip + (new properties-container-snip% + (controller controller))) + + (define/override (closed-contents) + (list the-summary)) + + (define/override (open-contents) + (list " " + the-syntax-snip + " " + properties-snip)) + + ;; Snip methods + (define/override (copy) + (new decorated-syntax-snip% + (syntax stx) + (controller controller) + (config config))) + (define/override (write stream) + (send stream put + (string->bytes/utf-8 + (format "~s" (marshall-syntax stx))))) + (define/public (read-special src line col pos) + (send the-syntax-snip read-special src line col pos)) + + (send/i config config<%> listen-props-shown? + (lambda (?) (refresh-contents))) + + (super-new) + (set-snipclass snip-class) + )) + +(define properties-container-snip% + (class clicky-snip% + (init controller) + + (define properties-snip + (new properties-snip% (controller controller))) + + (define/override (open-contents) + (list #;(show-properties-icon) + properties-snip)) + + (define/override (closed-contents) + (list (show-properties-icon))) + + (super-new (open-style '()) + (closed-style '())))) + +(define style:normal (make-object style-delta% 'change-normal)) +(define style:hyper + (let ([s (make-object style-delta% 'change-normal)]) + (send s set-delta 'change-toggle-underline) + (send s set-delta-foreground "blue") + s)) +(define style:green + (let ([s (make-object style-delta% 'change-normal)]) + (send s set-delta-foreground "darkgreen") + s)) +(define style:bold + (let ([s (make-object style-delta% 'change-normal)]) + (send s set-delta 'change-bold) + s)) + +(define (show-icon) + (make-object image-snip% + (build-path (collection-path "icons") "turn-up.png"))) +(define (hide-icon) + (make-object image-snip% + (build-path (collection-path "icons") "turn-down.png"))) + +(define (show-properties-icon) + (make-object image-snip% + (build-path (collection-path "icons") "syncheck.png"))) + + +;; SNIPCLASS + +;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt +(define decorated-syntax-snipclass% + (class snip-class% + (define/override (read stream) + (new decorated-syntax-snip% + (syntax (unmarshall-syntax + (read-from-string (send stream get-bytes)))))) + (super-new))) + +(define snip-class (make-object decorated-syntax-snipclass%)) +(send snip-class set-version 2) +(send snip-class set-classname + (format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.rkt"))) diff --git a/collects/macro-debugger/syntax-browser/snip.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/snip.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/text.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/text.rkt @@ -0,0 +1,475 @@ +#lang racket/base +(require racket/class + racket/gui/base + data/interval-map + drracket/arrow + framework + data/interval-map + macro-debugger/syntax-browser/interfaces) + +(provide text:hover<%> + text:hover-drawings<%> + text:arrows<%> + + text:hover-mixin + text:hover-drawings-mixin + text:tacking-mixin + text:arrows-mixin + text:region-data-mixin + text:clickregion-mixin + browser-text%) + +(define arrow-cursor (make-object cursor% 'arrow)) + +(define arrow-brush + (send the-brush-list find-or-create-brush "white" 'solid)) +(define (tacked-arrow-brush color) + (send the-brush-list find-or-create-brush color 'solid)) + +(define billboard-brush + (send the-brush-list find-or-create-brush "white" 'solid)) + +(define white (send the-color-database find-color "white")) + +;; A Drawing is (make-drawing (??? -> void) (box boolean)) +(define-struct drawing (draw tacked?)) + +(define-struct idloc (start end id)) + +(define (mean x y) + (/ (+ x y) 2)) + +;; save+restore pen, brush, also smoothing +(define-syntax with-saved-pen&brush + (syntax-rules () + [(with-saved-pen&brush dc . body) + (save-pen&brush dc (lambda () . body))])) + +(define (save-pen&brush dc thunk) + (let ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)] + [old-smoothing (send dc get-smoothing)]) + (begin0 (thunk) + (send* dc + (set-pen old-pen) + (set-brush old-brush) + (set-smoothing old-smoothing))))) + +(define-syntax with-saved-text-config + (syntax-rules () + [(with-saved-text-config dc . body) + (save-text-config dc (lambda () . body))])) + +(define (save-text-config dc thunk) + (let ([old-font (send dc get-font)] + [old-color (send dc get-text-foreground)] + [old-background (send dc get-text-background)] + [old-mode (send dc get-text-mode)]) + (begin0 (thunk) + (send* dc + (set-font old-font) + (set-text-foreground old-color) + (set-text-background old-background) + (set-text-mode old-mode))))) + +;; Interfaces + +(define text:region-data<%> + (interface (text:basic<%>) + get-region-mapping)) + +(define text:hover<%> + (interface (text:basic<%>) + update-hover-position)) + +(define text:hover-drawings<%> + (interface (text:basic<%>) + add-hover-drawing + get-position-drawings)) + +(define text:arrows<%> + (interface (text:hover-drawings<%>) + add-arrow + add-billboard)) + +;; Mixins + +(define text:region-data-mixin + (mixin (text:basic<%>) (text:region-data<%>) + + (define table (make-hasheq)) + + (define/public (get-region-mapping key) + (hash-ref! table key (lambda () (make-interval-map)))) + + (define/augment (after-delete start len) + (for ([im (in-hash-values table)]) + (interval-map-contract! im start (+ start len))) + (inner (void) after-delete start len)) + + (define/augment (after-insert start len) + (for ([im (in-hash-values table)]) + (interval-map-expand! im start (+ start len))) + (inner (void) after-insert start len)) + + (super-new))) + +(define text:hover-mixin + (mixin (text:basic<%>) (text:hover<%>) + (inherit dc-location-to-editor-location + find-position) + + (define/override (on-default-event ev) + (super on-default-event ev) + (case (send ev get-event-type) + ((enter motion leave) + (define-values (x y) + (let ([gx (send ev get-x)] + [gy (send ev get-y)]) + (dc-location-to-editor-location gx gy))) + (define on-it? (box #f)) + (define pos (find-position x y #f on-it?)) + (update-hover-position (and (unbox on-it?) pos))))) + + (define/public (update-hover-position pos) + (void)) + + (super-new))) + +(define text:hover-drawings-mixin + (mixin (text:hover<%> text:region-data<%>) (text:hover-drawings<%>) + (inherit dc-location-to-editor-location + find-position + invalidate-bitmap-cache + get-region-mapping) + (super-new) + + ;; interval-map of Drawings + (define drawings-list (get-region-mapping 'hover-drawings)) + + (field [hover-position #f]) + + (define/override (update-hover-position pos) + (define old-pos hover-position) + (super update-hover-position pos) + (set! hover-position pos) + (unless (same-drawings? old-pos pos) + (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))) + + (define/public (add-hover-drawing start end draw [tack-box (box #f)]) + (let ([drawing (make-drawing draw tack-box)]) + (interval-map-cons*! drawings-list + start (add1 end) + drawing + null))) + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (super on-paint before? dc left top right bottom dx dy draw-caret) + (unless before? + (for ([d (get-position-drawings hover-position)]) + ((drawing-draw d) this dc left top right bottom dx dy)))) + + (define/public (get-position-drawings pos) + (if pos (interval-map-ref drawings-list pos null) null)) + + (define/private (same-drawings? old-pos pos) + ;; relies on order drawings added & list-of-eq?-struct equality + (equal? (get-position-drawings old-pos) + (get-position-drawings pos))))) + +(define text:tacking-mixin + (mixin (text:basic<%> text:hover-drawings<%>) () + (inherit get-canvas + get-keymap + get-position-drawings) + (inherit-field hover-position) + (super-new) + + (define tacked-table (make-hasheq)) + + (define/override (on-local-event ev) + (case (send ev get-event-type) + ((right-down) + (if (pair? (get-position-drawings hover-position)) + (send (get-canvas) popup-menu + (make-tack/untack-menu (get-position-drawings hover-position)) + (send ev get-x) + (send ev get-y)) + (super on-local-event ev))) + (else + (super on-local-event ev)))) + + ;; Clear tacked-table on any modification. + ;; FIXME: possible to be more precise? (but not needed for macro stepper) + (define/augment (after-delete start len) + (set! tacked-table (make-hasheq)) + (inner (void) after-delete start len)) + (define/augment (after-insert start len) + (set! tacked-table (make-hasheq)) + (inner (void) after-insert start len)) + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (super on-paint before? dc left top right bottom dx dy draw-caret) + (unless before? + (for ([draw (in-hash-keys tacked-table)]) + (draw this dc left top right bottom dx dy)))) + + (define/private (make-tack/untack-menu drawings) + (define menu (new popup-menu%)) + (define keymap (get-keymap)) + (define tack-item + (new menu-item% (label "Tack") + (parent menu) + (callback (lambda _ (tack drawings))))) + (define untack-item + (new menu-item% (label "Untack") + (parent menu) + (callback (lambda _ (untack drawings))))) + (send tack-item enable + (for/or ([d (in-list drawings)]) (not (unbox (drawing-tacked? d))))) + (send untack-item enable + (for/or ([d (in-list drawings)]) (unbox (drawing-tacked? d)))) + (when (is-a? keymap keymap/popup<%>) + (new separator-menu-item% (parent menu)) + (send keymap add-context-menu-items menu)) + menu) + + (define/private (tack drawings) + (for ([d (in-list drawings)]) + (hash-set! tacked-table (drawing-draw d) #t) + (set-box! (drawing-tacked? d) #t))) + (define/private (untack drawings) + (for ([d (in-list drawings)]) + (hash-remove! tacked-table (drawing-draw d)) + (set-box! (drawing-tacked? d) #f))))) + +(define text:arrows-mixin + (mixin (text:hover-drawings<%>) (text:arrows<%>) + (inherit position-location + add-hover-drawing + find-wordbreak) + + (define/public (add-billboard pos1 pos2 str color-name) + (define color (send the-color-database find-color color-name)) + (let ([draw + (lambda (text dc left top right bottom dx dy) + (let-values ([(x y) (range->mean-loc pos1 pos1)] + [(fw fh _d _v) (send dc get-text-extent "y")]) + (with-saved-pen&brush dc + (with-saved-text-config dc + (send* dc + (set-pen color 1 'solid) + (set-brush billboard-brush) + (set-text-mode 'solid) + (set-font (billboard-font dc)) + (set-text-foreground color)) + (let-values ([(w h d v) (send dc get-text-extent str)] + [(adj-y) fh] + [(mini) _d]) + (send* dc + (set-smoothing 'smoothed) + (draw-rounded-rectangle + (+ x dx) + (+ y dy adj-y) + (+ w mini mini) + (+ h mini mini)) + (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))]) + (add-hover-drawing pos1 pos2 draw))) + + (define/public (add-arrow from1 from2 to1 to2 color-name label where) + (define color (send the-color-database find-color color-name)) + (define tack-box (box #f)) + (unless (and (= from1 to1) (= from2 to2)) + (let ([draw + (lambda (text dc left top right bottom dx dy) + (let-values ([(startx starty) (range->mean-loc from1 from2)] + [(endx endy) (range->mean-loc to1 to2)] + [(fw fh _d _v) (send dc get-text-extent "x")] + [(lw lh ld _V) (send dc get-text-extent (or label "x"))]) + (with-saved-pen&brush dc + (with-saved-text-config dc + (send dc set-pen color 1 'solid) + (send dc set-brush + (if (unbox tack-box) + (tacked-arrow-brush color) + arrow-brush)) + (draw-arrow dc startx + (+ starty (/ fh 2)) + endx + (+ endy (/ fh 2)) + dx dy) + (when label + (let* ([lx (+ endx dx fw)] + [ly (- (+ endy dy) fh)]) + (send* dc + (set-brush billboard-brush) + (set-font (billboard-font dc)) + (set-text-foreground color) + (set-smoothing 'smoothed) + (draw-rounded-rectangle (- lx ld) (- ly ld) + (+ lw ld ld) (+ lh ld ld)) + (draw-text label lx ly))))))))]) + (add-hover-drawing from1 from2 draw tack-box) + (add-hover-drawing to1 to2 draw tack-box)))) + + (define/private (position->location p) + (define xbox (box 0.0)) + (define ybox (box 0.0)) + (position-location p xbox ybox) + (values (unbox xbox) (unbox ybox))) + + (define/private (?-font dc) + (let ([size (send (send dc get-font) get-point-size)]) + (send the-font-list find-or-create-font size 'default 'normal 'bold))) + + (define/private (billboard-font dc) + (let ([size (send (send dc get-font) get-point-size)]) + (send the-font-list find-or-create-font size 'default 'normal))) + + (define/private (range->mean-loc pos1 pos2) + (let*-values ([(loc1x loc1y) (position->location pos1)] + [(loc2x loc2y) (position->location pos2)] + [(locx) (mean loc1x loc2x)] + [(locy) (mean loc1y loc2y)]) + (values locx locy))) + + (super-new))) + +#| +text:clickregion-mixin + +Like clickbacks, but: + - use interval-map to avoid linear search + (major problem w/ macro stepper and large expansions!) + - callback takes position of click, not (start, end) + - different rules for removal + - TODO: extend to double-click +|# +(define text:clickregion-mixin + (mixin (text:region-data<%>) () + (inherit get-admin + get-region-mapping + dc-location-to-editor-location + find-position) + + (super-new) + + ;; Two mappings: one for left clicks, another for right + ;; mouse-downs. Rationale: macro stepper wants to handle left + ;; clicks normally, but wants to insert behavior (ie, change + ;; focus) before normal processing of right-down (ie, editor + ;; passes to keymap, opens popup menu). + (define clickbacks (get-region-mapping 'click-region)) + (define right-clickbacks (get-region-mapping 'right-click-region)) + (define tracking #f) + + (define/public (set-clickregion start end callback [region 'click]) + (let ([mapping + (case region + ((click) clickbacks) + ((right-down) right-clickbacks) + (else (error 'set-clickregion + "bad region symbol: expected 'click or 'right-down, got ~e" + region)))]) + (if callback + (interval-map-set! mapping start end callback) + (interval-map-remove! mapping start end)))) + + (define/private (get-event-position ev) + (define-values (x y) + (let ([gx (send ev get-x)] + [gy (send ev get-y)]) + (dc-location-to-editor-location gx gy))) + (define on-it? (box #f)) + (define pos (find-position x y #f on-it?)) + (and (unbox on-it?) pos)) + + ;; on-default-event called if keymap does not handle event + (define/override (on-default-event ev) + (define admin (get-admin)) + (when admin + (define pos (get-event-position ev)) + (case (send ev get-event-type) + ((left-down) + (set! tracking (and pos (interval-map-ref clickbacks pos #f))) + (send admin update-cursor)) + ((left-up) + (when tracking + (let ([cb (and pos (interval-map-ref clickbacks pos #f))] + [tracking* tracking]) + (set! tracking #f) + (when (eq? tracking* cb) + (cb pos))) + (send admin update-cursor))))) + (super on-default-event ev)) + + ;; on-local-event called before keymap consulted + (define/override (on-local-event ev) + (case (send ev get-event-type) + ((right-down) + (when (get-admin) + (define pos (get-event-position ev)) + (let ([cb (and pos (interval-map-ref right-clickbacks pos #f))]) + (when cb (cb pos)))))) + (super on-local-event ev)) + + (define/override (adjust-cursor ev) + (define pos (get-event-position ev)) + (define cb (and pos (interval-map-ref clickbacks pos #f))) + (if cb + arrow-cursor + (super adjust-cursor ev))))) + + +#| +(define text:hover-identifier<%> + (interface () + get-hovered-identifier + set-hovered-identifier + listen-hovered-identifier)) + +(define text:hover-identifier-mixin + (mixin (text:hover<%>) (text:hover-identifier<%>) + (define-notify hovered-identifier (new notify-box% (value #f))) + + (define idlocs null) + + (define/public (add-identifier-location start end id) + (set! idlocs (cons (make-idloc start end id) idlocs))) + + (define/public (delete-all-identifier-locations) + (set! idlocs null) + (set-hovered-identifier #f)) + + (define/override (update-hover-position pos) + (super update-hover-position pos) + (let search ([idlocs idlocs]) + (cond [(null? idlocs) (set-hovered-identifier #f)] + [(and (<= (idloc-start (car idlocs)) pos) + (< pos (idloc-end (car idlocs)))) + (set-hovered-identifier (idloc-id (car idlocs)))] + [else (search (cdr idlocs))]))) + (super-new))) +|# + + +(define browser-text% + (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) + (class (text:clickregion-mixin + (text:arrows-mixin + (text:tacking-mixin + (text:hover-drawings-mixin + (text:hover-mixin + (text:region-data-mixin + (text:hide-caret/selection-mixin + (text:foreground-color-mixin + (editor:standard-style-list-mixin text:basic%))))))))) + (inherit set-autowrap-bitmap get-style-list) + (define/override (default-style-name) browser-text-default-style-name) + (super-new (auto-wrap #t)) + (let* ([sl (get-style-list)] + [standard (send sl find-named-style (editor:get-default-color-style-name))] + [browser-basic (send sl find-or-create-style standard + (make-object style-delta% 'change-family 'default))]) + (send sl new-named-style browser-text-default-style-name browser-basic)) + (set-autowrap-bitmap #f)))) diff --git a/collects/macro-debugger/syntax-browser/util.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/util.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/widget.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/syntax-browser/widget.rkt @@ -0,0 +1,269 @@ +#lang racket/base +(require racket/class + racket/gui/base + racket/match + framework + syntax/id-table + unstable/class-iop + macro-debugger/syntax-browser/interfaces + "controller.rkt" + "display.rkt" + "keymap.rkt" + "hrule-snip.rkt" + "properties.rkt" + "text.rkt" + "util.rkt" + macro-debugger/util/eomap + macro-debugger/util/logger + macro-debugger/util/mpi) +(provide widget%) + +;; widget% +;; A syntax widget creates its own syntax-controller. +(define widget% + (class* object% (syntax-browser<%> widget-hooks<%>) + (init parent) + (init-field config) + + (field [controller (new controller%)]) + + (define -main-panel + (new vertical-panel% (parent parent))) + (define -split-panel + (new panel:horizontal-dragable% (parent -main-panel))) + (define -text (new browser-text%)) + (define -ecanvas + (new canvas:color% (parent -split-panel) (editor -text))) + (define -props-panel + (new horizontal-panel% (parent -split-panel) (style '(deleted)))) + (define props + (new properties-view% + (parent -props-panel) + (controller controller))) + + (define/public (setup-keymap) + (new syntax-keymap% + (editor -text) + (controller controller) + (config config))) + + (send -text set-styles-sticky #f) + (send -text lock #t) + + (define/public (show-props show?) + (internal-show-props show?)) + + (define saved-props-percentage #f) + + (define/private (internal-show-props show?) + (if show? + (unless (send -props-panel is-shown?) + (send -split-panel begin-container-sequence) + (let ([p (or saved-props-percentage + (send/i config config<%> get-props-percentage))]) + (send -split-panel add-child -props-panel) + (update-props-percentage p)) + (send -props-panel show #t) + (send -split-panel end-container-sequence)) + (when (send -props-panel is-shown?) + (send -split-panel begin-container-sequence) + (set! saved-props-percentage + (cadr (send -split-panel get-percentages))) + (send -split-panel delete-child -props-panel) + (send -props-panel show #f) + (send -split-panel end-container-sequence)))) + + (define/private (update-props-percentage p) + (send -split-panel set-percentages + (list (- 1 p) p))) + + (define/private (props-panel-shown?) + (send -props-panel is-shown?)) + + ;; + + (define/public (get-controller) + controller) + + ;; + + (define/public (get-main-panel) + -main-panel) + + (define/public (shutdown) + (when (props-panel-shown?) + (send/i config config<%> set-props-percentage + (cadr (send -split-panel get-percentages))))) + + ;; syntax-browser<%> Methods + + (define/public (add-text text) + (with-unlock -text + (send -text insert text))) + + (define/public (add-error-text text) + (with-unlock -text + (let ([a (send -text last-position)]) + (send -text insert text) + (let ([b (send -text last-position)]) + (send -text change-style error-text-style a b))))) + + (define/public (add-clickback text handler) + (with-unlock -text + (let ([a (send -text last-position)]) + (send -text insert text) + (let ([b (send -text last-position)]) + (send -text set-clickback a b handler) + (send -text change-style clickback-style a b))))) + + (define/public (add-syntax stx + #:binders [binders '#hash()] + #:shift-table [shift-table '#hash()] + #:definites [definites #f] + #:hi-colors [hi-colors null] + #:hi-stxss [hi-stxss null] + #:substitutions [substitutions null]) + (define (get-shifted id) (hash-ref shift-table id null)) + + (with-unlock -text + (define display + (print-syntax-to-editor stx -text controller config + (calculate-columns) + (send -text last-position))) + (send -text insert "\n") + (define range (send/i display display<%> get-range)) + (define offset (send/i display display<%> get-start-position)) + (with-log-time "substitutions" + (for ([subst (in-list substitutions)]) + (for ([r (in-list (send/i range range<%> get-ranges (car subst)))]) + (send -text insert (cdr subst) + (+ offset (car r)) + (+ offset (cdr r)) + #f) + (send -text change-style + (code-style -text (send/i config config<%> get-syntax-font-size)) + (+ offset (car r)) + (+ offset (cdr r)) + #f)))) + ;; Apply highlighting + (with-log-time "highlights" + (for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)]) + (send/i display display<%> highlight-syntaxes hi-stxs hi-color))) + ;; Underline binders (and shifted binders) + (with-log-time "underline binders" + (send/i display display<%> underline-syntaxes + (let ([binder-list (hash-map binders (lambda (k v) k))]) + (append (apply append (map get-shifted binder-list)) + binder-list)))) + (send display refresh) + + ;; Make arrows (& billboards, when enabled) + (with-log-time "add arrows" + (when (send config get-draw-arrows?) + (define (definite-phase id) + (and definites + (or (eomap-ref definites id #f) + (for/or ([shifted (in-list (hash-ref shift-table id null))]) + (eomap-ref definites shifted #f))))) + + (define phase-binder-table (make-hash)) + (define (get-binder-table phase) + (hash-ref! phase-binder-table phase (lambda () (make-free-id-table #:phase phase)))) + (for ([(binder phase) (in-hash binders)]) + (free-id-table-set! (get-binder-table phase) binder binder)) + + (define (get-binders id phase) + (define (for-one-table table id) + (let ([binder (free-id-table-ref table id #f)]) + (cond [(not binder) null] + [shift-table (cons binder (get-shifted binder))] + [else (list binder)]))) + (cond [phase (for-one-table (get-binder-table phase) id)] + [else + (apply append + (for/list ([table (in-hash-values phase-binder-table)]) + (for-one-table table id)))])) + + (for ([id (in-list (send/i range range<%> get-identifier-list))]) + (define phase (definite-phase id)) + (when #f ;; DISABLED + (add-binding-billboard offset range id phase)) + (for ([binder (in-list (get-binders id phase))]) + (for ([binder-r (in-list (send/i range range<%> get-ranges binder))]) + (for ([id-r (in-list (send/i range range<%> get-ranges id))]) + (add-binding-arrow offset binder-r id-r phase))))))) + (void))) + + (define/private (add-binding-arrow start binder-r id-r phase) + ;; phase = #f means not definite binding (ie, "?" arrow) + (send -text add-arrow + (+ start (car binder-r)) + (+ start (cdr binder-r)) + (+ start (car id-r)) + (+ start (cdr id-r)) + (if phase "blue" "purple") + (cond [(equal? phase 0) #f] + [phase (format "phase ~s" phase)] + [else "?"]) + (if phase 'end 'start))) + + (define/private (add-binding-billboard start range id definite?) + (match (identifier-binding id) + [(list-rest src-mod src-name nom-mod nom-name _) + (for ([id-r (in-list (send/i range range<%> get-ranges id))]) + (send -text add-billboard + (+ start (car id-r)) + (+ start (cdr id-r)) + (string-append "from " (mpi->string src-mod)) + (if definite? "blue" "purple")))] + [_ (void)])) + + (define/public (add-separator) + (with-unlock -text + (send* -text + (insert (new hrule-snip%)) + (insert "\n")))) + + (define/public (erase-all) + (with-unlock -text + (send -text erase)) + (send/i controller displays-manager<%> remove-all-syntax-displays)) + + (define/public (get-text) -text) + + (define/private (calculate-columns) + (define style (code-style -text (send/i config config<%> get-syntax-font-size))) + (define char-width (send style get-text-width (send -ecanvas get-dc))) + #| + (define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) + (sub1 (inexact->exact (floor (/ canvas-w char-width)))) + |# + (let ([admin (send -text get-admin)] + [w-box (box 0.0)]) + (send admin get-view #f #f w-box #f) + (sub1 (inexact->exact (floor (/ (unbox w-box) char-width)))))) + + ;; Initialize + (super-new) + (setup-keymap) + + (send/i config config<%> listen-props-shown? + (lambda (show?) + (show-props show?))) + (send/i config config<%> listen-props-percentage + (lambda (p) + (update-props-percentage p))) + (internal-show-props (send/i config config<%> get-props-shown?)))) + + +(define clickback-style + (let ([sd (new style-delta%)]) + (send sd set-delta 'change-toggle-underline) + (send sd set-delta-foreground "blue") + sd)) + +(define error-text-style + (let ([sd (new style-delta%)]) + (send sd set-delta 'change-italic) + (send sd set-delta-foreground "red") + sd)) diff --git a/collects/macro-debugger/tests/test-docs-complete.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/tests/test-docs-complete.rkt diff --git a/collects/macro-debugger/util/logger.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/util/logger.rkt diff --git a/collects/macro-debugger/view/cursor.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/cursor.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/debug.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/debug.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require racket/pretty + racket/class + unstable/class-iop + "interfaces.rkt" + macro-debugger/view/debug-format + "view.rkt") +(provide debug-file) + +(define (widget-mixin %) + (class % + (define/override (top-interaction-kw? x) + (eq? (syntax-e x) '#%top-interaction)) + (super-new))) + +(define stepper-frame% + (class macro-stepper-frame% + (define/override (get-macro-stepper-widget%) + (widget-mixin (super get-macro-stepper-widget%))) + (super-new))) + +(define (make-stepper) + (define director (new macro-stepper-director%)) + (send director new-stepper)) + +(define (debug-file file) + (let-values ([(events msg ctx) (load-debug-file file)]) + (pretty-print msg) + (pretty-print ctx) + (let* ([w (make-stepper)]) + (send/i w widget<%> add-trace events) + w))) diff --git a/collects/macro-debugger/view/extensions.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/extensions.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/frame.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/frame.rkt @@ -0,0 +1,279 @@ +#lang racket/base +(require racket/class + racket/path + racket/gui/base + framework + unstable/class-iop + "interfaces.rkt" + "stepper.rkt" + (prefix-in sb: "../syntax-browser/embed.rkt") + (prefix-in sb: macro-debugger/syntax-browser/interfaces) + unstable/gui/notify) +(provide macro-stepper-frame-mixin) + +(define-syntax override/return-false + (syntax-rules () + [(override/return-false m ...) + (begin (define/override (m) #f) ...)])) + +(define (macro-stepper-frame-mixin base-frame%) + (class* base-frame% (stepper-frame<%>) + (init-field config) + (init-field director) + (init-field (filename #f)) + + (define obsoleted? #f) + + (inherit get-area-container + get-size + 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/i config config<%> get-width)) + (height (send/i config 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")) + + ;; Grrr... we get a spurious on-size event sometime after the + ;; frame is created, probably when the window-manager gets around + ;; to doing something. Avoid unnecessary updates. + (define-values (w0 h0) (get-size)) + (define/override (on-size w h) + (send/i config config<%> set-width w) + (send/i config config<%> set-height h) + (unless (and (= w0 w) (= h0 h)) + (when (send/i config config<%> get-refresh-on-resize?) + (send/i widget widget<%> update/preserve-view))) + (set!-values (w0 h0) (values w h))) + + (define warning-panel + (new horizontal-panel% + (parent (get-area-container)) + (stretchable-height #f) + (style '(deleted)))) + + (define/public (get-macro-stepper-widget%) + macro-stepper-widget%) + + (define/i widget widget<%> + (new (get-macro-stepper-widget%) + (parent (get-area-container)) + (director director) + (config config))) + (define/i controller sb:controller<%> + (send/i widget widget<%> get-controller)) + + (define/public (get-widget) widget) + (define/public (get-controller) controller) + + (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 + + (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?) + + (define stepper-menu + (new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) + + (define/override (file-menu:between-save-as-and-print file-menu) + (super file-menu:between-save-as-and-print file-menu) + (new separator-menu-item% (parent file-menu)) + (new (get-menu-item%) + (label "Duplicate stepper") + (parent file-menu) + (callback (lambda _ (send/i widget widget<%> duplicate-stepper)))) + (new (get-menu-item%) + (label "Duplicate stepper (current term only)") + (parent file-menu) + (callback (lambda _ (send/i widget widget<%> show-in-new-frame)))) + (new separator-menu-item% (parent file-menu))) + + (menu-option/notify-box stepper-menu + "View syntax properties" + (get-field props-shown? config)) + + (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/i controller sb:controller<%> set-identifier=? p))))]) + (send/i controller sb:controller<%> listen-identifier=? + (lambda (name+func) + (send this-choice check + (eq? (car name+func) (car p))))))) + (sb:identifier=-choices))) + + (let ([identifier=? (send/i config config<%> get-identifier=?)]) + (when identifier=? + (let ([p (assoc identifier=? (sb:identifier=-choices))]) + (send/i controller sb:controller<%> set-identifier=? p)))) + + (new (get-menu-item%) + (label "Clear selection") + (parent stepper-menu) + (callback + (lambda _ (send/i controller sb:controller<%> + set-selected-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 "Remove selected term") + (parent stepper-menu) + (callback (lambda _ (send/i widget widget<%> remove-current-term)))) + (new (get-menu-item%) + (label "Reset mark numbering") + (parent stepper-menu) + (callback (lambda _ (send/i widget widget<%> reset-primary-partition)))) + (let ([extras-menu + (new (get-menu%) + (label "Extra options") + (parent stepper-menu))]) + (new checkable-menu-item% + (label "Always suffix marked identifiers") + (parent extras-menu) + (callback + (lambda (i e) + (send/i config config<%> set-suffix-option + (if (send i is-checked?) + 'always + 'over-limit)) + (send/i widget widget<%> update/preserve-view)))) + (menu-option/notify-box extras-menu + "Factor out common context?" + (get-field split-context? config)) + (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 + "Refresh on resize" + (get-field refresh-on-resize? config)) + (menu-option/notify-box extras-menu + "Close old stepper on Run" + (get-field close-on-reset-console? config)) + (menu-option/notify-box extras-menu + "Draw binding arrows" + (get-field draw-arrows? config)) + (menu-option/notify-box extras-menu + "Enable reader abbreviations" + (get-field pretty-abbrev? config)) + (menu-option/notify-box extras-menu + "Extra navigation" + (get-field extra-navigation? config))) + + ;; fixup-menu : menu -> void + ;; Delete separators at beginning/end and duplicates in middle + (define/private (fixup-menu menu) + (define items + (filter (lambda (i) (not (send i is-deleted?))) + (send menu get-items))) + (define (delete-seps-loop items) + (if (and (pair? items) (is-a? (car items) separator-menu-item%)) + (begin (send (car items) delete) + (delete-seps-loop (cdr items))) + items)) + (define (middle-loop items) + (cond + [(and (pair? items) (is-a? (car items) separator-menu-item%)) + (middle-loop (delete-seps-loop (cdr items)))] + [(pair? items) + (middle-loop (cdr items))] + [else null])) + (middle-loop (delete-seps-loop items)) + (delete-seps-loop (reverse items)) + (void)) + + (for ([menu (send (get-menu-bar) get-items)]) + (fixup-menu menu)) + (frame:remove-empty-menus this) + (frame:reorder-menus this))) + +;; 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))) diff --git a/collects/macro-debugger/view/gui-util.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/gui-util.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/hiding-panel.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/hiding-panel.rkt @@ -0,0 +1,339 @@ +#lang racket/base +(require racket/class + racket/gui/base + racket/match + unstable/class-iop + "interfaces.rkt" + macro-debugger/model/hiding-policies + macro-debugger/util/mpi + unstable/gui/notify) +(provide macro-hiding-prefs-widget%) + +(define mode:disable "Disable") +(define mode:standard "Standard") +(define mode:custom "Custom ...") + +#| + +TODO + + - allow entry of more policies + - visual feedback on rules applying to selected identifier + (need to switch from list to editor) + +|# + +;; macro-hiding-prefs-widget% +(define macro-hiding-prefs-widget% + (class* object% (hiding-prefs<%>) + (init parent) + (init-field/i (stepper widget<%>)) + (init-field config) + + (define/public (get-policy) + (let ([mode (get-mode)]) + (cond [(not (macro-hiding-enabled?)) #f] + [(equal? mode mode:standard) standard-policy] + [(equal? mode mode:custom) (get-custom-policy)]))) + + (define/private (get-custom-policy) + (let ([hide-racket? (send box:hide-racket get-value)] + [hide-libs? (send box:hide-libs get-value)] + [hide-contracts? (send box:hide-contracts get-value)] + [hide-transformers? (send box:hide-phase1 get-value)] + [specialized-policies (get-specialized-policies)]) + (policy->predicate + `(custom ,hide-racket? + ,hide-libs? + ,hide-contracts? + ,hide-transformers? + ,specialized-policies)))) + + (define super-panel + (new vertical-panel% + (parent parent) + (stretchable-height #f))) + (define top-line-panel + (new horizontal-panel% + (parent super-panel) + (alignment '(left center)) + (stretchable-height #f))) + (define customize-panel + (new horizontal-panel% + (parent super-panel) + (stretchable-height #f) + (alignment '(left top)) + (style '(deleted)))) + (define left-pane + (new vertical-pane% + (parent customize-panel) + (stretchable-width #f) + (alignment '(left top)))) + (define right-pane + (new vertical-pane% + (parent customize-panel))) + + (define mode-selector + (choice/notify-box + top-line-panel + "Macro hiding: " + (list mode:disable mode:standard mode:custom) + (get-field macro-hiding-mode config))) + (define top-line-inner-panel + (new horizontal-panel% + (parent top-line-panel) + (alignment '(right center)) + (style '(deleted)))) + + (define/private (get-mode) + (send/i config config<%> get-macro-hiding-mode)) + + (define/private (macro-hiding-enabled?) + (let ([mode (get-mode)]) + (or (equal? mode mode:standard) + (and (equal? mode mode:custom) + (send box:hiding get-value))))) + + (define/private (ensure-custom-mode) + (unless (equal? (get-mode) mode:custom) + (send/i config config<%> set-macro-hiding-mode mode:custom))) + + (define/private (update-visibility) + (let ([customizing (equal? (get-mode) mode:custom)]) + (send top-line-panel change-children + (lambda (children) + (append (remq top-line-inner-panel children) + (if customizing (list top-line-inner-panel) null)))) + (send super-panel change-children + (lambda (children) + (append (remq customize-panel children) + (if (and customizing (send box:edit get-value)) + (list customize-panel) + null)))))) + + (send/i config config<%> listen-macro-hiding-mode + (lambda (value) + (update-visibility) + (force-refresh))) + + (define box:hiding + (new check-box% + (label "Enable macro hiding") + (value #t) + (parent top-line-inner-panel) + (callback (lambda (c e) (force-refresh))))) + (define box:edit + (new check-box% + (label "Show policy editor") + (parent top-line-inner-panel) + (value #t) + (callback (lambda (c e) (update-visibility))))) + + (define box:hide-racket + (new check-box% + (label "Hide racket syntax") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) + (define box:hide-libs + (new check-box% + (label "Hide library syntax") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) + (define box:hide-contracts + (new check-box% + (label "Hide contracts (heuristic)") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) + (define box:hide-phase1 + (new check-box% + (label "Hide phase>0") + (parent left-pane) + (value #t) + (callback (lambda (c e) (refresh))))) + + (define look-ctl + (new list-box% (parent right-pane) (label "") + (choices null) (style '(extended)) + (callback + (lambda (c e) + (send delete-ctl enable (pair? (send c get-selections))))))) + + (define look-button-pane + (new horizontal-pane% (parent right-pane) (stretchable-width #f))) + + (define delete-ctl + (new button% (parent look-button-pane) (label "Delete rule") (enabled #f) + (callback (lambda _ (delete-selected) (refresh))))) + (define add-hide-id-button + (new button% (parent look-button-pane) (label "Hide macro") (enabled #f) + (callback (lambda _ (add-hide-identifier) (refresh))))) + (define add-show-id-button + (new button% (parent look-button-pane) (label "Show macro") (enabled #f) + (callback (lambda _ (add-show-identifier) (refresh))))) + ;;(new grow-box-spacer-pane% (parent right-pane)) + + ;; Methods + + (define stx #f) + + ;; refresh : -> void + (define/public (refresh) + (when (macro-hiding-enabled?) + (send/i stepper widget<%> refresh/resynth))) + + ;; force-refresh : -> void + (define/private (force-refresh) + (send/i stepper widget<%> refresh/resynth)) + + ;; set-syntax : syntax/#f -> void + (define/public (set-syntax lstx) + (set! stx (and (identifier? lstx) lstx)) + (send add-show-id-button enable (identifier? lstx)) + (send add-hide-id-button enable (identifier? lstx))) + + ;; A PolicyLine is an Entry + ;; Entry is defined in ../model/hiding-policies + + ;; identifier-policies : (listof Entry) + (define identifier-policies null) + + ;; get-specialized-policies : -> (listof Entry) + (define/private (get-specialized-policies) + identifier-policies) + + (define/public (add-hide-identifier) + (when (identifier? stx) + (add-policy-line 'hide-if `(free=? ,stx)))) + + (define/public (add-show-identifier) + (when (identifier? stx) + (add-policy-line 'show-if `(free=? ,stx)))) + + ;; add-policy-line : 'show-if/'hide-if Condition -> void + (define/private (add-policy-line action condition) + (set! identifier-policies + (cons `(,action ,condition) + (remove-policy/condition condition identifier-policies))) + (update-list-view) + (ensure-custom-mode)) + + ;; update-list-view : -> void + (define/private (update-list-view) + (send look-ctl set null) + (for ([policy identifier-policies]) + (send look-ctl append (policy->string policy) policy))) + + ;; delete-selected : -> void + (define/private (delete-selected) + (define to-delete (sort (send look-ctl get-selections) <)) + (set! identifier-policies + (let loop ([i 0] [policies identifier-policies] [to-delete to-delete]) + (cond [(null? to-delete) policies] + [(= i (car to-delete)) + (loop (add1 i) (cdr policies) (cdr to-delete))] + [else + (cons (car policies) + (loop (add1 i) (cdr policies) to-delete))]))) + (update-list-view)) + + (super-new) + (update-visibility))) + + +(define (remove-policy/condition condition policies) + (filter (lambda (p) (not (same-condition? (cadr p) condition))) + policies)) + + +;; ---- + +(define (policy->string policy) + (string-limit 200 + (string-append + (case (car policy) + ((show-if) "show ") + ((hide-if) "hide ")) + (condition->string (cadr policy))))) + +(define (string-limit size s) + (cond [(> (string-length s) size) + (string-append (substring s 0 (- size 3)) "...")] + [else s])) + +(define (condition->string condition) + (match condition + [`(free=? ,id) + (let ([b (identifier-binding id)]) + (or #| (identifier->string id) |# + (cond [(list? b) + (let ([mod (caddr b)] + [name (cadddr b)]) + (if (self-mpi? mod) + (format "'~a' defined in this module" name) + (format "'~s' imported from ~a" name (mpi->string mod))))] + [else + (symbol->string (syntax-e id))])))] + [_ + "<condition>"])) + +#| +(require scribble/xref + scribble/manual-struct + setup/xref) + +(define xref-p (delay (load-collections-xref))) + +(define (identifier->string id) + (define binding-info (identifier-binding id)) + (define xref (force xref-p)) + (define definition-tag + (and xref + (xref-binding->definition-tag xref binding-info #f))) + (and definition-tag + (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) + (define index-entry + (and path (xref-tag->index-entry xref definition-tag))) + (define desc + (and index-entry (entry-desc index-entry))) + (and desc + (let ([name (exported-index-desc-name desc)] + [libs (exported-index-desc-from-libs desc)]) + (format "'~a' from ~a" + name + (mpi->string (car libs)))))))) +|# + + + +#| +(define (get-id-key id) + id + #; ;; FIXME + (let ([binding (identifier-binding id)]) + (get-id-key/binding id binding))) + +(define (get-id-key/binding id binding) + (cond [(pair? binding) + (list (car binding) (cadr binding))] + [else id])) + +(define (key=? key1 key2) + (cond [(and (identifier? key1) (identifier? key2)) + (free-identifier=? key1 key2)] + [(and (pair? key1) (pair? key2)) + (and (equal? (car key1) (car key2)) + (equal? (cadr key1) (cadr key2)))] + [else #f])) + +(define (key->text key) + (cond [(pair? key) + (let ([name (cadddr key)] + [mod (caddr key)]) + (format "'~s' from ~a" + name + (mpi->string mod)))] + [else (symbol->string (syntax-e key))])) +|# diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/interfaces.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/interfaces.rkt @@ -0,0 +1,93 @@ +#lang racket/base +(require unstable/class-iop + (prefix-in sb: macro-debugger/syntax-browser/interfaces)) +(provide (all-defined-out)) + +(define-interface config<%> (sb:config<%>) + ((sb:methods:notify draw-arrows? + refresh-on-resize? + macro-hiding-mode + show-hiding-panel? + identifier=? + highlight-foci? + highlight-frontier? + show-rename-steps? + suppress-warnings? + one-by-one? + extra-navigation? + debug-catch-errors? + split-context?))) + +(define-interface widget<%> () + (get-config + get-controller + get-macro-hiding-prefs + get-step-displayer + + add-trace + add-deriv + + update/preserve-view + refresh/resynth + + reset-primary-partition + remove-current-term + duplicate-stepper + show-in-new-frame + + get-preprocess-deriv + get-show-macro? +)) + +(define-interface stepper-frame<%> () + (get-widget + get-controller + add-obsoleted-warning)) + +(define-interface hiding-prefs<%> () + (add-show-identifier + add-hide-identifier + set-syntax + get-policy + refresh)) + + +(define-interface step-display<%> () + (add-syntax + add-step + add-error + add-final + add-internal-error)) + + +(define-interface term-record<%> () + (get-raw-deriv + get-deriv-hidden? + get-step-index + get-step-count + invalidate-synth! + invalidate-steps! + + has-prev? + has-next? +#| + at-start? + at-end? +|# + navigate-to-start + navigate-to-end + navigate-previous + navigate-next + navigate-to + + on-get-focus + on-lose-focus + + display-initial-term + display-final-term + display-step + )) + +(define-interface director<%> () + (add-deriv + new-stepper)) diff --git a/collects/macro-debugger/view/prefs.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/prefs.rkt diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/step-display.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/step-display.rkt @@ -0,0 +1,269 @@ +#lang racket/base +(require racket/class + racket/match + racket/gui/base + unstable/class-iop + "interfaces.rkt" + macro-debugger/model/steps + (prefix-in sb: macro-debugger/syntax-browser/interfaces) + macro-debugger/view/debug-format) + +#; +(provide step-display% + step-display<%>) +(provide (all-defined-out)) +;; Struct for one-by-one stepping + +(define-struct (prestep protostep) ()) +(define-struct (poststep protostep) ()) + +(define (prestep-term1 s) (state-term (protostep-s1 s))) +(define (poststep-term2 s) (state-term (protostep-s1 s))) + +(define step-display% + (class* object% (step-display<%>) + + (init-field/i (config config<%>)) + (init-field ((sbview syntax-widget))) + (super-new) + + (define/public (add-internal-error part exn stx events) + (send/i sbview sb:syntax-browser<%> add-text + (string-append + (if (exn:break? exn) + "Macro stepper was interrupted" + "Macro stepper error") + (if part + (format " (~a)" part) + ""))) + (when (exn? exn) + (send/i sbview sb:syntax-browser<%> add-text " ") + (send/i sbview sb:syntax-browser<%> add-clickback "[details]" + (lambda _ (show-internal-error-details exn events)))) + (send/i sbview sb:syntax-browser<%> add-text ". ") + (when stx (send/i sbview sb:syntax-browser<%> add-text "Original syntax:")) + (send/i sbview sb:syntax-browser<%> add-text "\n") + (when stx (send/i sbview sb:syntax-browser<%> add-syntax stx))) + + (define/private (show-internal-error-details exn events) + (case (message-box/custom (if (exn:break? exn) + "Macro stepper was interrupted" + "Macro stepper internal error") + (format "Internal error:\n~a" (exn-message exn)) + "Show error" + "Dump debugging file" + "Cancel") + ((1) (queue-callback + (lambda () + (raise exn)))) + ((2) (queue-callback + (lambda () + (let ([file (put-file)]) + (when file + (write-debug-file file exn events)))))) + ((3 #f) (void)))) + + (define/public (add-error exn) + (send*/i sbview sb:syntax-browser<%> + (add-error-text (exn-message exn)) + (add-text "\n"))) + + (define/public (add-step step + #:shift-table [shift-table #f]) + (cond [(step? step) + (show-step step shift-table)] + [(misstep? step) + (show-misstep step shift-table)] + [(remarkstep? step) + (show-remarkstep step shift-table)] + [(prestep? step) + (show-prestep step shift-table)] + [(poststep? step) + (show-poststep step shift-table)])) + + (define/public (add-syntax stx + #:binders [binders '#hash()] + #:definites [definites #f] + #:shift-table [shift-table '#hash()]) + (send/i sbview sb:syntax-browser<%> add-syntax stx + #:binders binders + #:definites definites + #:shift-table shift-table)) + + (define/public (add-final stx error + #:binders binders + #:definites definites + #:shift-table [shift-table #f]) + (when stx + (send*/i sbview sb:syntax-browser<%> + (add-text "Expansion finished\n") + (add-syntax stx + #:binders binders + #:definites definites + #:shift-table shift-table))) + (when error + (add-error error))) + + ;; show-lctx : Step -> void + (define/private (show-lctx step shift-table) + (define state (protostep-s1 step)) + (define lctx (state-lctx state)) + (for ([bf lctx]) + (send/i sbview sb:syntax-browser<%> add-text + "\nwhile executing macro transformer in:\n") + (insert-syntax/redex (bigframe-term bf) + (bigframe-foci bf) + (state-binders state) + shift-table + (state-uses state) + (state-frontier state)))) + + ;; separator : Step [...] -> void + (define/private (separator step #:compact? [compact? #f]) + (insert-step-separator (step-type->string (protostep-type step)) + #:compact? compact?)) + + ;; show-step : Step -> void + (define/private (show-step step shift-table) + (let-values ([(common-context state1 state2) + (factor-common-context (protostep-s1 step) + (step-s2 step))]) + (show-state/redex state1 shift-table) + (separator step) + (show-state/contractum state2 shift-table) + (show-common-context common-context state1 shift-table) + (show-lctx step shift-table))) + + (define/private (factor-common-context state1 state2) + (if (send/i config config<%> get-split-context?) + (factor-common-context* state1 state2) + (values null state1 state2))) + + (define/private (factor-common-context* state1 state2) + (match-define + (struct state (e1 foci1 ctx1 lctx1 binders1 uses1 frontier1 seq1)) state1) + (match-define + (struct state (e2 foci2 ctx2 lctx2 binders2 uses2 frontier2 seq2)) state2) + (define (common xs ys acc) + (if (and (pair? xs) (pair? ys) (eq? (car xs) (car ys))) + (common (cdr xs) (cdr ys) (cons (car xs) acc)) + (values (reverse xs) (reverse ys) acc))) + (define-values (ctx1z ctx2z common-ctx) + (common (reverse ctx1) (reverse ctx2) null)) + (define state1z + (make-state e1 foci1 ctx1z lctx1 binders1 uses1 frontier1 seq1)) + (define state2z + (make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2)) + (values common-ctx state1z state2z)) + + (define/private (show-common-context ctx state1 shift-table) + (match-define + (struct state (_ _ _ _ _ uses1 frontier1 _)) state1) + (when (pair? ctx) + (let* ([hole-stx #'~~HOLE~~] + [the-syntax (context-fill ctx hole-stx)]) + (send*/i sbview sb:syntax-browser<%> + (add-text "\nin context:\n") + (add-syntax the-syntax + #:definites uses1 + #:binders (state-binders state1) + #:shift-table shift-table + #:substitutions (list (cons hole-stx "[ HOLE ]"))))))) + + (define/private (show-state/redex state shift-table) + (insert-syntax/redex (state-term state) + (state-foci state) + (state-binders state) + shift-table + (state-uses state) + (state-frontier state))) + + (define/private (show-state/contractum state shift-table) + (insert-syntax/contractum (state-term state) + (state-foci state) + (state-binders state) + shift-table + (state-uses state) + (state-frontier state))) + + ;; show-prestep : Step -> void + (define/private (show-prestep step shift-table) + (separator step #:compact? #t) + (show-state/redex (protostep-s1 step) shift-table) + (show-lctx step shift-table)) + + ;; show-poststep : Step -> void + (define/private (show-poststep step shift-table) + (separator step #:compact? #t) + (show-state/contractum (protostep-s1 step) shift-table) + (show-lctx step shift-table)) + + ;; show-misstep : Step -> void + (define/private (show-misstep step shift-table) + (define state (protostep-s1 step)) + (separator step #:compact? #t) + (send*/i sbview sb:syntax-browser<%> + (add-error-text (exn-message (misstep-exn step))) + (add-text "\n")) + (when (exn:fail:syntax? (misstep-exn step)) + (for ([e (exn:fail:syntax-exprs (misstep-exn step))]) + (send/i sbview sb:syntax-browser<%> add-syntax e + #:binders (state-binders state) + #:definites (state-uses state) + #:shift-table shift-table))) + (show-lctx step shift-table)) + + (define/private (show-remarkstep step shift-table) + (define state (protostep-s1 step)) + (for ([content (in-list (remarkstep-contents step))]) + (cond [(string? content) + (send*/i sbview sb:syntax-browser<%> + (add-text content) + (add-text "\n"))] + [(syntax? content) + (send*/i sbview sb:syntax-browser<%> + (add-syntax content + #:binders (state-binders state) + #:definites (state-uses state) + #:shift-table shift-table) + (add-text "\n"))])) + (show-lctx step shift-table)) + + ;; insert-syntax/color + (define/private (insert-syntax/color stx foci binders shift-table + definites frontier hi-color) + (define highlight-foci? (send/i config config<%> get-highlight-foci?)) + (define highlight-frontier? (send/i config config<%> get-highlight-frontier?)) + (send/i sbview sb:syntax-browser<%> add-syntax stx + #:definites definites + #:binders binders + #:shift-table shift-table + #:hi-colors (list hi-color + "WhiteSmoke") + #:hi-stxss (list (if highlight-foci? foci null) + (if highlight-frontier? frontier null)))) + + ;; insert-syntax/redex + (define/private (insert-syntax/redex stx foci binders shift-table + definites frontier) + (insert-syntax/color stx foci binders shift-table + definites frontier "MistyRose")) + + ;; insert-syntax/contractum + (define/private (insert-syntax/contractum stx foci binders shift-table + definites frontier) + (insert-syntax/color stx foci binders shift-table + definites frontier "LightCyan")) + + ;; insert-step-separator : string -> void + (define/private (insert-step-separator text #:compact? compact?) + (send*/i sbview sb:syntax-browser<%> + (add-text (if compact? "" "\n")) + (add-text + (make-object image-snip% + (build-path (collection-path "icons") + "red-arrow.bmp"))) + (add-text " [") + (add-text text) + (add-text "]\n\n"))) + )) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/stepper.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/stepper.rkt @@ -0,0 +1,578 @@ +#lang racket/base +(require racket/class + racket/match + racket/gui/base + unstable/class-iop + "interfaces.rkt" + "extensions.rkt" + "hiding-panel.rkt" + "term-record.rkt" + "step-display.rkt" + (prefix-in sb: macro-debugger/syntax-browser/interfaces) + macro-debugger/model/deriv + macro-debugger/model/deriv-util + "cursor.rkt" + "gui-util.rkt" + "../syntax-browser/util.rkt" + unstable/gui/notify + images/compile-time + images/gui + (for-syntax racket/base + images/icons/arrow images/icons/control images/logos + images/icons/style) + (only-in mzscheme [#%top-interaction mz-top-interaction])) +(provide macro-stepper-widget% + macro-stepper-widget/process-mixin) + +;; Compiled-in assets (button icons) + +(define navigate-up-icon + (compiled-bitmap (up-arrow-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) +(define navigate-to-start-icon + (compiled-bitmap (search-backward-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) +(define navigate-previous-icon + (compiled-bitmap (step-back-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) +(define navigate-next-icon + (compiled-bitmap (step-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) +(define navigate-to-end-icon + (compiled-bitmap (search-forward-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) +(define navigate-down-icon + (compiled-bitmap (down-arrow-icon #:color syntax-icon-color #:height (toolbar-icon-height)))) + +(define small-logo (compiled-bitmap (macro-stepper-logo #:height 32))) +(define large-logo (compiled-bitmap (macro-stepper-logo))) + +(define (show-about-dialog parent) + (define dlg + (new logo-about-dialog% + (label "About the Macro Stepper") + (parent parent) + (bitmap large-logo) + (messages '("The Macro Stepper is formalized and proved correct in\n" + "\n" + " Ryan Culpepper and Matthias Felleisen\n" + " Debugging Hygienic Macros\n" + " Science of Computer Programming, July 2010\n")))) + (send dlg show #t)) + +;; Macro Stepper + +;; macro-stepper-widget% +(define macro-stepper-widget% + (class* object% (widget<%>) + (init-field parent) + (init-field config) + (init-field/i (director director<%>)) + + (define frame (send parent get-top-level-window)) + (define eventspace (send frame get-eventspace)) + + (define-syntax-rule (with-eventspace . body) + (parameterize ((current-eventspace eventspace)) + (queue-callback (lambda () . body)))) + + ;; Terms + + ;; all-terms : (list-of TermRecord) + ;; (Reversed) + (define all-terms null) + + ;; terms : (Cursor-of TermRecord) + ;; Contains visible terms of all-terms + (define terms (cursor:new null)) + + ;; focused-term : -> TermRecord or #f + (define (focused-term) + (cursor:next terms)) + + ;; current-step-index : notify of number/#f + (define-notify current-step-index (new notify-box% (value #f))) + + ;; add-deriv : Deriv -> void + (define/public (add-deriv d) + (let ([trec (new term-record% (stepper this) (raw-deriv d))]) + (add trec))) + + ;; add-trace : (list-of event) -> void + (define/public (add-trace events) + (let ([trec (new term-record% (stepper this) (events events))]) + (add trec))) + + ;; add : TermRecord -> void + (define/private (add trec) + (with-eventspace + (set! all-terms (cons trec all-terms)) + (let ([display-new-term? (cursor:at-end? terms)] + [invisible? (send/i trec term-record<%> get-deriv-hidden?)]) + (unless invisible? + (cursor:add-to-end! terms (list trec)) + (trim-navigator) + (if display-new-term? + (refresh) + (update)))))) + + ;; remove-current-term : -> void + (define/public (remove-current-term) + (when (cursor:has-next? terms) + (cursor:remove-current! terms) + (trim-navigator) + (refresh))) + + ;; show-in-new-frame : -> void + (define/public (show-in-new-frame) + (let ([term (focused-term)]) + (when term + (let ([new-stepper (send/i director director<%> new-stepper '(no-new-traces))]) + (send/i new-stepper widget<%> add-deriv (send/i term term-record<%> get-raw-deriv)) + (void))))) + + ;; duplicate-stepper : -> void + (define/public (duplicate-stepper) + (let ([new-stepper (send/i director director<%> new-stepper)]) + (for ([term (cursor->list terms)]) + (send/i new-stepper widget<%> add-deriv + (send/i term term-record<%> get-raw-deriv))))) + + (define/public (get-config) config) + (define/public (get-controller) sbc) + (define/public (get-view) sbview) + (define/public (get-step-displayer) step-displayer) + (define/public (get-macro-hiding-prefs) macro-hiding-prefs) + + (define/public (reset-primary-partition) + (send/i sbc sb:controller<%> reset-primary-partition) + (update/preserve-view)) + + (define superarea (new vertical-pane% (parent parent))) + (define area + (new vertical-panel% + (parent superarea) + (enabled #f))) + (define top-panel + (new horizontal-panel% + (parent area) + (horiz-margin 5) + (stretchable-height #f))) + (define supernavigator + (new horizontal-panel% + (parent top-panel) + (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 logo-canvas + (new (class bitmap-canvas% + (super-new (parent top-panel) (bitmap small-logo)) + (define/override (on-event evt) + (when (eq? (send evt get-event-type) 'left-up) + (show-about-dialog frame)))))) + + (define/i sbview sb:syntax-browser<%> + (new stepper-syntax-widget% + (parent area) + (macro-stepper this))) + (define/i step-displayer step-display<%> + (new step-display% + (config config) + (syntax-widget sbview))) + (define/i sbc sb:controller<%> + (send/i sbview sb:syntax-browser<%> get-controller)) + (define control-pane + (new vertical-panel% (parent area) (stretchable-height #f))) + + (define/i macro-hiding-prefs hiding-prefs<%> + (new macro-hiding-prefs-widget% + (parent control-pane) + (stepper this) + (config config))) + + (define status-area + (new status-area% + (parent superarea) + (stop-callback (lambda _ (stop-processing))))) + + (send/i sbc sb:controller<%> + listen-selected-syntax + (lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx))) + (send config listen-pretty-abbrev? + (lambda (_) (update/preserve-view))) + (send*/i config config<%> + (listen-show-hiding-panel? + (lambda (show?) (show-macro-hiding-panel show?))) + (listen-split-context? + (lambda (_) (update/preserve-view))) + (listen-highlight-foci? + (lambda (_) (update/preserve-view))) + (listen-highlight-frontier? + (lambda (_) (update/preserve-view))) + (listen-show-rename-steps? + (lambda (_) (refresh/re-reduce))) + (listen-one-by-one? + (lambda (_) (refresh/re-reduce))) + (listen-extra-navigation? + (lambda (show?) (show-extra-navigation show?)))) + (send config listen-pretty-styles + (lambda (_) (update/preserve-view))) + + (define nav:up + (new button% (label (list navigate-up-icon "Previous term" 'left)) (parent navigator) + (callback (lambda (b e) (navigate-up))))) + (define nav:start + (new button% (label (list navigate-to-start-icon "Start" 'left)) (parent navigator) + (callback (lambda (b e) (navigate-to-start))))) + (define nav:previous + (new button% (label (list navigate-previous-icon "Step" 'left)) (parent navigator) + (callback (lambda (b e) (navigate-previous))))) + (define nav:next + (new button% (label (list navigate-next-icon "Step" 'right)) (parent navigator) + (callback (lambda (b e) (navigate-next))))) + (define nav:end + (new button% (label (list navigate-to-end-icon "End" 'right)) (parent navigator) + (callback (lambda (b e) (navigate-to-end))))) + (define nav:down + (new button% (label (list navigate-down-icon "Next term" 'right)) (parent navigator) + (callback (lambda (b e) (navigate-down))))) + + (define nav:text + (new text-field% + (label "Step#") + (init-value "00000") + (parent extra-navigator) + (stretchable-width #f) + (stretchable-height #f) + (callback + (lambda (b e) + (when (eq? (send e get-event-type) 'text-field-enter) + (let* ([value (send b get-value)] + [step (string->number value)]) + (cond [(exact-positive-integer? step) + (navigate-to (sub1 step))] + [(equal? value "end") + (navigate-to-end)]))))))) + + (define nav:step-count + (new message% + (label "") + (parent extra-navigator) + (auto-resize #t) + (stretchable-width #f) + (stretchable-height #f))) + (send nav:text set-value "") + + (listen-current-step-index + (lambda (n) + (send nav:text set-value + (if (number? n) (number->string (add1 n)) "")))) + + (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-panel show?) + (send area change-children + (lambda (children) + (if show? + (append (remq control-pane children) (list control-pane)) + (remq control-pane children))))) + + (define/private (show-extra-navigation show?) + (send supernavigator change-children + (lambda (children) + (if show? + (list navigator extra-navigator) + (list navigator))))) + + (define/public (change-status msg) + (send status-area set-status msg)) + + ;; Navigation + (define/public-final (navigate-to-start) + (send/i (focused-term) term-record<%> navigate-to-start) + (update/preserve-lines-view)) + (define/public-final (navigate-to-end) + (send/i (focused-term) term-record<%> navigate-to-end) + (update/preserve-lines-view)) + (define/public-final (navigate-previous) + (send/i (focused-term) term-record<%> navigate-previous) + (update/preserve-lines-view)) + (define/public-final (navigate-next) + (send/i (focused-term) term-record<%> navigate-next) + (update/preserve-lines-view)) + (define/public-final (navigate-to n) + (send/i (focused-term) term-record<%> navigate-to n) + (update/preserve-lines-view)) + + (define/public-final (navigate-up) + (when (focused-term) + (send/i (focused-term) term-record<%> on-lose-focus)) + (cursor:move-prev terms) + (refresh/move)) + (define/public-final (navigate-down) + (when (focused-term) + (send/i (focused-term) term-record<%> on-lose-focus)) + (cursor:move-next terms) + (refresh/move)) + + ;; enable/disable-buttons : -> void + (define/private (enable/disable-buttons [? #t]) + (define term (and ? (focused-term))) + ;; (message-box "alert" (format "enable/disable: ~s" ?)) + (send area enable ?) + (send (send frame get-menu-bar) enable ?) + (send nav:start enable (and ? term (send/i term term-record<%> has-prev?))) + (send nav:previous enable (and ? term (send/i term term-record<%> has-prev?))) + (send nav:next enable (and ? term (send/i term term-record<%> has-next?))) + (send nav:end enable (and ? term (send/i term term-record<%> has-next?))) + (send nav:text enable (and ? term #t)) + (send nav:up enable (and ? (cursor:has-prev? terms))) + (send nav:down enable (and ? (cursor:has-next? terms))) + (send status-area enable-stop (not ?))) + + ;; Async update & refresh + + (define update-thread #f) + + (define ASYNC-DELAY 500) ;; milliseconds + + (define/private (call-with-update-thread thunk) + (send status-area set-visible #f) + (let* ([lock (make-semaphore 1)] ;; mutex for status variable + [status #f] ;; mutable: one of #f, 'done, 'async + [thd + (parameterize-break #f + (thread (lambda () + (with-handlers ([exn:break? + (lambda (e) + (change-status "Interrupted") + (void))]) + (parameterize-break #t + (thunk) + (change-status #f))) + (semaphore-wait lock) + (case status + ((async) + (set! update-thread #f) + (with-eventspace + (enable/disable-buttons #t))) + (else + (set! status 'done))) + (semaphore-post lock))))]) + (sync thd (alarm-evt (+ (current-inexact-milliseconds) ASYNC-DELAY))) + (semaphore-wait lock) + (case status + ((done) + ;; Thread finished; enable/disable skipped, so do it now to update. + (enable/disable-buttons #t)) + (else + (set! update-thread thd) + (send status-area set-visible #t) + (enable/disable-buttons #f) + (set! status 'async))) + (semaphore-post lock))) + + (define-syntax-rule (with-update-thread . body) + (call-with-update-thread (lambda () . body))) + + (define/private (stop-processing) + (let ([t update-thread]) + (when t (break-thread t)))) + + ;; Update + + ;; update/preserve-lines-view : -> void + (define/public (update/preserve-lines-view) + (with-update-thread + (define text (send/i sbview sb:syntax-browser<%> get-text)) + (define start-box (box 0)) + (define end-box (box 0)) + (send text get-visible-line-range start-box end-box) + (update*) + (send text scroll-to-position + (send text line-start-position (unbox start-box)) + #f + (send text line-start-position (unbox end-box)) + 'start))) + + ;; update/preserve-view : -> void + (define/public (update/preserve-view) + (with-update-thread + (define text (send/i sbview sb:syntax-browser<%> get-text)) + (define start-box (box 0)) + (define end-box (box 0)) + (send text get-visible-position-range start-box end-box) + (update*) + (send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))) + + ;; update : -> void + ;; Updates the terms in the syntax browser to the current step + (define/private (update) + (with-update-thread + (update*))) + + (define/private (update*) + ;; update:show-prefix : -> void + (define (update:show-prefix) + ;; Show the final terms from the cached synth'd derivs + (for ([trec (in-list (cursor:prefix->list terms))]) + (send/i trec term-record<%> display-final-term))) + ;; update:show-current-step : -> void + (define (update:show-current-step) + (when (focused-term) + (send/i (focused-term) term-record<%> display-step))) + ;; update:show-suffix : -> void + (define (update:show-suffix) + (let ([suffix0 (cursor:suffix->list terms)]) + (when (pair? suffix0) + (for ([trec (in-list (cdr suffix0))]) + (send/i trec term-record<%> display-initial-term))))) + ;; update-nav-index : -> void + (define (update-nav-index) + (define term (focused-term)) + (set-current-step-index + (and term (send/i term term-record<%> get-step-index)))) + + (define text (send/i sbview sb:syntax-browser<%> get-text)) + (define position-of-interest 0) + (define multiple-terms? (> (length (cursor->list terms)) 1)) + + (with-unlock text + (send/i sbview sb:syntax-browser<%> erase-all) + (update:show-prefix) + (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) + (set! position-of-interest (send text last-position)) + (update:show-current-step) + (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) + (update:show-suffix)) + + (send text scroll-to-position + position-of-interest + #f + (send text last-position) + 'start) + (update-nav-index) + (change-status #f)) + + ;; -- + + ;; refresh/resynth : -> void + ;; Macro hiding policy has changed; invalidate cached parts of trec + (define/public (refresh/resynth) + (for ([trec (in-list (cursor->list terms))]) + (send/i trec term-record<%> invalidate-synth!)) + (refresh)) + + ;; refresh/re-reduce : -> void + ;; Reduction config has changed; invalidate cached parts of trec + (define/private (refresh/re-reduce) + (for ([trec (in-list (cursor->list terms))]) + (send/i trec term-record<%> invalidate-steps!)) + (refresh)) + + ;; refresh/move : -> void + ;; Moving between terms; clear the saved position + (define/private (refresh/move) + (refresh)) + + ;; refresh : -> void + (define/public (refresh) + (with-update-thread + (when (focused-term) + (send/i (focused-term) term-record<%> on-get-focus)) + (send nav:step-count set-label "") + (let ([term (focused-term)]) + (when term + (let ([step-count (send/i term term-record<%> get-step-count)]) + (when step-count + ;; +1 for end of expansion "step" + (send nav:step-count set-label (format "of ~s" (add1 step-count))))))) + (update*))) + + ;; Hiding policy + + (define/public (get-show-macro?) + (send/i macro-hiding-prefs hiding-prefs<%> get-policy)) + + ;; Derivation pre-processing + + (define/public (get-preprocess-deriv) (lambda (d) d)) + + ;; Initialization + + (super-new) + (show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?)) + (show-extra-navigation (send/i config config<%> get-extra-navigation?)) + )) + +(define (macro-stepper-widget/process-mixin %) + (class % + (super-new) + (define/override (get-preprocess-deriv) + (lambda (d) (get-original-part d))) + + ;; get-original-part : Deriv -> Deriv/#f + ;; Strip off mzscheme's #%top-interaction + ;; Careful: the #%top-interaction node may be inside of a lift-deriv + (define/private (get-original-part deriv) + (let ([deriv* (adjust-deriv/lift deriv)]) + deriv*)) + + ;; adjust-deriv/lift : Deriv -> Deriv/#f + (define/private (adjust-deriv/lift deriv) + (match deriv + [(Wrap lift-deriv (e1 e2 first lifted-stx second)) + (let ([first (adjust-deriv/lift first)]) + (and first + (let ([e1 (wderiv-e1 first)]) + (make-lift-deriv e1 e2 first lifted-stx second))))] + [(Wrap ecte (e1 e2 '() first second locals2)) + ;; Only adjust if no locals... + (let ([first (adjust-deriv/lift first)]) + (and first + (let ([e1 (wderiv-e1 first)]) + (make ecte e1 e2 '() first second locals2))))] + [else (adjust-deriv/top deriv)])) + + ;; adjust-deriv/top : Derivation -> Derivation + (define/private (adjust-deriv/top deriv) + (if (or (not (base? deriv)) + (syntax-original? (wderiv-e1 deriv)) + (p:module? deriv)) + deriv + ;; It's not original... + ;; Strip out mzscheme's top-interactions + ;; Keep anything that is a non-mzscheme top-interaction + (cond [(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x)) + ;; Just mzscheme's top-interaction; strip it out + (adjust-deriv/top (mrule-next deriv))] + [else deriv]))) + + (define/public (top-interaction-kw? x) + (or (free-identifier=? x #'#%top-interaction) + (free-identifier=? x #'mz-top-interaction))) + + )) diff --git a/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/term-record.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/term-record.rkt @@ -0,0 +1,352 @@ +#lang racket/base +(require racket/class + racket/match + syntax/stx + unstable/find + unstable/class-iop + "interfaces.rkt" + "step-display.rkt" + macro-debugger/model/deriv + macro-debugger/model/deriv-util + macro-debugger/model/deriv-parser + macro-debugger/model/trace + macro-debugger/model/reductions-config + macro-debugger/model/reductions + macro-debugger/model/steps + "cursor.rkt") + +(provide term-record%) + +;; TermRecords + +(define term-record% + (class* object% (term-record<%>) + (init-field/i (stepper widget<%>)) + + (define/i config config<%> + (send/i stepper widget<%> get-config)) + (define/i displayer step-display<%> + (send/i stepper widget<%> get-step-displayer)) + + ;; Data + + (init-field [events #f]) + + (init-field [raw-deriv #f]) + (define raw-deriv-oops #f) + + (define deriv #f) + (define deriv-hidden? #f) + (define shift-table #f) + + (define raw-steps #f) + (define raw-steps-estx #f) ;; #f if raw-steps-exn is exn + (define raw-steps-exn #f) ;; #f if raw-steps-estx is syntax + (define raw-steps-binders #f) + (define raw-steps-definites #f) + (define raw-steps-oops #f) + + (define steps #f) + + ;; -- + + (define steps-position #f) + + (define/private (status msg) + (send stepper change-status msg)) + (define-syntax-rule (with-status msg . body) + (begin (send stepper change-status msg) + (begin0 (let () . body)))) + + (super-new) + + (define-syntax define-guarded-getters + (syntax-rules () + [(define-guarded-getters guard (method expr) ...) + (begin (define/public (method) guard expr) ...)])) + + (define/public (get-events) events) + (define/public (get-raw-deriv) raw-deriv) + + (define-guarded-getters (recache-deriv!) + [get-deriv deriv] + [get-deriv-hidden? deriv-hidden?] + [get-shift-table shift-table]) + (define-guarded-getters (recache-raw-steps!) + [get-raw-steps-binders raw-steps-binders] + [get-raw-steps-definites raw-steps-definites] + [get-raw-steps-exn raw-steps-exn] + [get-raw-steps-oops raw-steps-oops]) + (define-guarded-getters (recache-steps!) + [get-steps steps]) + + ;; invalidate-steps! : -> void + ;; Invalidates cached parts that depend on reductions config + (define/public (invalidate-steps!) + (set! steps #f)) + + ;; invalidate-raw-steps! : -> void + (define/public (invalidate-raw-steps!) + (invalidate-steps!) + (set! raw-steps #f) + (set! raw-steps-estx #f) + (set! raw-steps-exn #f) + (set! raw-steps-binders #f) + (set! raw-steps-definites #f) + (set! raw-steps-oops #f)) + + ;; invalidate-synth! : -> void + ;; Invalidates cached parts that depend on macro-hiding policy + (define/public (invalidate-synth!) + (invalidate-raw-steps!)) + + ;; invalidate-deriv! : -> void + (define/public (invalidate-deriv!) + (invalidate-synth!) + (set! deriv #f) + (set! deriv-hidden? #f) + (set! shift-table #f)) + + ;; recache! : -> void + (define/public (recache!) + (recache-steps!)) + + ;; recache-raw-deriv! : -> void + (define/private (recache-raw-deriv!) + (unless (or raw-deriv raw-deriv-oops) + (with-handlers ([(lambda (e) #t) + (lambda (e) + (set! raw-deriv-oops e))]) + (with-status "Parsing expansion derivation" + (set! raw-deriv + (parse-derivation + (events->token-generator events))))))) + + ;; recache-deriv! : -> void + (define/private (recache-deriv!) + (unless (or deriv deriv-hidden?) + (recache-raw-deriv!) + (when raw-deriv + (with-status "Processing expansion derivation" + (let ([process (send/i stepper widget<%> get-preprocess-deriv)]) + (let ([d (process raw-deriv)]) + (when (not d) + (set! deriv-hidden? #t)) + (when d + (set! deriv d) + (set! shift-table (compute-shift-table d))))))))) + + ;; recache-synth! : -> void + (define/private (recache-synth!) + (recache-deriv!)) + + ;; recache-raw-steps! : -> void + (define/private (recache-raw-steps!) + (unless (or raw-steps raw-steps-oops) + (recache-synth!) + (when deriv + (with-status "Computing reduction steps" + (let ([show-macro? (or (send/i stepper widget<%> get-show-macro?) + (lambda (id) #t))]) + (with-handlers ([(lambda (e) #t) + (lambda (e) + (set! raw-steps-oops e))]) + (let-values ([(raw-steps* binders* definites* estx* error*) + (parameterize ((macro-policy show-macro?)) + (reductions+ deriv))]) + (set! raw-steps raw-steps*) + (set! raw-steps-estx estx*) + (set! raw-steps-exn error*) + (set! raw-steps-binders binders*) + (set! raw-steps-definites definites*)))))))) + + ;; recache-steps! : -> void + (define/private (recache-steps!) + (unless (or steps) + (recache-raw-steps!) + (when raw-steps + (with-status "Processing reduction steps" + (set! steps + (and raw-steps + (let* ([filtered-steps + (if (send/i config config<%> get-show-rename-steps?) + raw-steps + (filter (lambda (x) (not (rename-step? x))) + raw-steps))] + [processed-steps + (if (send/i config config<%> get-one-by-one?) + (reduce:one-by-one filtered-steps) + filtered-steps)]) + (cursor:new processed-steps)))) + (restore-position))))) + + ;; reduce:one-by-one : (list-of step) -> (list-of step) + (define/private (reduce:one-by-one rs) + (let loop ([rs rs]) + (match rs + [(cons (struct step (type s1 s2)) rs) + (list* (make prestep type s1) + (make poststep type s2) + (loop rs))] + [(cons (struct misstep (type s1 exn)) rs) + (list* (make misstep type s1 exn) + (loop rs))] + [(cons (and r (remarkstep type s1 contents)) rs) + (list* r (loop rs))] + ['() + null]))) + + ;; Navigation + + (define/public-final (has-prev?) + (and (get-steps) (not (cursor:at-start? (get-steps))))) + (define/public-final (has-next?) + (and (get-steps) (not (cursor:at-end? (get-steps))))) + + (define/public-final (get-step-index) + (let ([steps (get-steps)]) + (and steps (cursor-position steps)))) + (define/public-final (get-step-count) + (let ([steps (get-steps)]) + (and steps (cursor-count steps)))) + + (define/public-final (navigate-to-start) + (cursor:move-to-start (get-steps)) + (save-position)) + (define/public-final (navigate-to-end) + (cursor:move-to-end (get-steps)) + (save-position)) + (define/public-final (navigate-previous) + (cursor:move-prev (get-steps)) + (save-position)) + (define/public-final (navigate-next) + (cursor:move-next (get-steps)) + (save-position)) + (define/public-final (navigate-to n) + (cursor:skip-to (get-steps) n) + (save-position)) + + ;; save-position : -> void + (define/private (save-position) + (when (cursor? steps) + (let ([step (cursor:next steps)]) + (cond [(not step) + ;; At end; go to the end when restored + (set! steps-position +inf.0)] + [(protostep? step) + (set! steps-position + (extract-protostep-seq step))])))) + + ;; restore-position : number -> void + (define/private (restore-position) + (define (seek) + (let ([step (cursor:next steps)]) + (cond [(not step) + ;; At end; stop + (void)] + [(protostep? step) + (let ([step-pos (extract-protostep-seq step)]) + (cond [(not step-pos) + (cursor:move-next steps) + (seek)] + [(< step-pos steps-position) + (cursor:move-next steps) + (seek)] + [else (void)]))]))) + (when steps-position + (seek))) + + ;; extract-protostep-seq : step -> number/#f + (define/private (extract-protostep-seq step) + ;; FIXME: add back step numbers + (state-seq (protostep-s1 step))) + + ;; Warnings display + + ;; on-get-focus : -> void + (define/public (on-get-focus) + (recache-synth!)) + + ;; on-lose-focus : -> void + (define/public (on-lose-focus) + (when steps (cursor:move-to-start steps)) + (set! steps-position #f)) + + ;; Rendering + + ;; display-initial-term : -> void + (define/public (display-initial-term) + (with-status "Rendering term" + (cond [raw-deriv-oops + (send/i displayer step-display<%> add-internal-error + "derivation" raw-deriv-oops #f events)] + [else + (send/i displayer step-display<%> add-syntax (wderiv-e1 deriv))]))) + + ;; display-final-term : -> void + (define/public (display-final-term) + (recache-steps!) + (with-status "Rendering term" + (cond [(syntax? raw-steps-estx) + (send/i displayer step-display<%> add-syntax raw-steps-estx + #:binders raw-steps-binders + #:shift-table shift-table + #:definites raw-steps-definites)] + [(exn? raw-steps-exn) + (send/i displayer step-display<%> add-error raw-steps-exn)] + [else (display-oops #f)]))) + + ;; display-step : -> void + (define/public (display-step) + (recache-steps!) + (with-status "Rendering step" + (cond [steps + (let ([step (cursor:next steps)]) + (if step + (send/i displayer step-display<%> add-step step + #:shift-table shift-table) + (send/i displayer step-display<%> add-final raw-steps-estx raw-steps-exn + #:binders raw-steps-binders + #:shift-table shift-table + #:definites raw-steps-definites)))] + [else (display-oops #t)]))) + + ;; display-oops : boolean -> void + (define/private (display-oops show-syntax?) + (cond [raw-steps-oops + (send/i displayer step-display<%> add-internal-error + "steps" raw-steps-oops + (and show-syntax? (wderiv-e1 deriv)) + events)] + [raw-deriv-oops + (send/i displayer step-display<%> add-internal-error + "derivation" raw-deriv-oops #f events)] + [else + (error 'term-record::display-oops "internal error")])) + )) + + +;; compute-shift-table : deriv -> hash[id => (listof id)] +(define (compute-shift-table d) + (define ht (make-hasheq)) + (define module-forms + (find p:module? d #:stop-on-found? #t)) + (define module-shift-renamers + (for/list ([mf module-forms]) + (let ([shift (p:module-shift mf)] + [body (p:module-body mf)]) + (and shift body + (with-syntax ([(_module _name _lang shifted-body) shift]) + (add-rename-mapping ht (wderiv-e2 body) #'shifted-body)))))) + ht) + +(define (add-rename-mapping ht from to) + (define (loop from to) + (cond [(and (stx-pair? from) (stx-pair? to)) + (loop (stx-car from) (stx-car to)) + (loop (stx-cdr from) (stx-cdr to))] + [(and (identifier? from) (identifier? to)) + (hash-set! ht from (cons to (hash-ref ht from null)))] + [else (void)])) + (loop from to) + (void)) diff --git a/collects/macro-debugger/view/view.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/macro-debugger/view/view.rkt diff --git a/collects/unstable/find.rkt b/pkgs/macro-debugger-pkgs/macro-debugger/unstable/find.rkt diff --git a/collects/tests/macro-debugger/all-tests.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/all-tests.rkt diff --git a/collects/tests/macro-debugger/check-requires/src-a.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/check-requires/src-a.rkt diff --git a/collects/tests/macro-debugger/check-requires/src-b.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/check-requires/src-b.rkt diff --git a/collects/tests/macro-debugger/check-requires/src-c.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/check-requires/src-c.rkt diff --git a/collects/tests/macro-debugger/check-requires/use-a.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/check-requires/use-a.rkt diff --git a/collects/tests/macro-debugger/check-requires/use-cs.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/check-requires/use-cs.rkt diff --git a/collects/tests/macro-debugger/gentest-framework.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/gentest-framework.rkt diff --git a/collects/tests/macro-debugger/gentests.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/gentests.rkt diff --git a/collects/tests/macro-debugger/gui-tests.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/gui-tests.rkt diff --git a/collects/tests/macro-debugger/test-setup.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/test-setup.rkt diff --git a/collects/tests/macro-debugger/tests/collects.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/collects.rkt diff --git a/collects/tests/macro-debugger/tests/hiding.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/hiding.rkt diff --git a/collects/tests/macro-debugger/tests/policy.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/policy.rkt diff --git a/collects/tests/macro-debugger/tests/regression.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/regression.rkt diff --git a/collects/tests/macro-debugger/tests/syntax-basic.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/syntax-basic.rkt diff --git a/collects/tests/macro-debugger/tests/syntax-errors.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/syntax-errors.rkt diff --git a/collects/tests/macro-debugger/tests/syntax-macros.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/syntax-macros.rkt diff --git a/collects/tests/macro-debugger/tests/syntax-modules.rkt b/pkgs/racket-pkgs/racket-test/tests/macro-debugger/tests/syntax-modules.rkt diff --git a/collects/unstable/scribblings/find.scrbl b/pkgs/unstable/scribblings/find.scrbl