diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 99cc067..2ef4287 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -5,7 +5,8 @@ "interfaces.ss" "../util/notify.ss" "../util/misc.ss") -(provide syntax-prefs-base% +(provide prefs-base% + syntax-prefs-base% syntax-prefs% syntax-prefs/readonly%) @@ -19,7 +20,7 @@ (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) -(define syntax-prefs-base% +(define prefs-base% (class object% ;; columns : number (field/notify columns (new notify-box% (value 60))) @@ -41,6 +42,10 @@ "indigo" "purple" "orange" "salmon" "darkgoldenrod" "olive")))) + (super-new))) + +(define syntax-prefs-base% + (class prefs-base% ;; width, height : number (notify-methods width) (notify-methods height) diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index 538d4e7..87cda89 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -1,363 +1,359 @@ -(module syntax-snip mzscheme - (require mzlib/class - mred - framework - mzlib/match - mzlib/list - mzlib/string - "../util/notify.ss" - "interfaces.ss" - "display.ss" - "controller.ss" - "keymap.ss" - "properties.ss" - "partition.ss" - "prefs.ss") +#lang scheme/base +(require scheme/class + scheme/match + scheme/list + mzlib/string + mred + framework + "../util/notify.ss" + "interfaces.ss" + "display.ss" + "controller.ss" + "keymap.ss" + "properties.ss" + "partition.ss" + "prefs.ss") - (provide syntax-snip% - syntax-value-snip%) +(provide syntax-snip% + syntax-value-snip%) - (define syntax-snip-config-base% - (class object% - (notify-methods props-shown?) - (super-new))) - (define syntax-snip-config% - (class syntax-snip-config-base% - (define/override (init-props-shown?) (new notify-box% (value #f))) - (super-new))) +(define syntax-snip-config-base% + (class prefs-base% + (notify-methods props-shown?) + (super-new))) - (define dumb-host% - (class object% - (define controller (new controller%)) - (define config (new syntax-snip-config%)) - (super-new) - (define/public (get-controller) controller) - (define/public (get-config) config) - (define/public (add-keymap text snip) - (send text set-keymap - (new syntax-keymap% - (controller controller) - (editor text) - (config config)))))) +(define syntax-snip-config% + (class syntax-snip-config-base% + (define/override (init-props-shown?) (new notify-box% (value #f))) + (super-new))) - ;; syntax-value-snip% - (define syntax-value-snip% - (class* editor-snip% (readable-snip<%>) - (init-field ((stx syntax))) - (init-field (host (new dumb-host%))) - (inherit set-margin - set-inset) +;; syntax-value-snip% +(define syntax-value-snip% + (class* editor-snip% (readable-snip<%>) + (init-field ((stx syntax))) + (init-field (controller (new controller%))) + (init-field (config (new syntax-snip-config%))) - (define text (new text:standard-style-list%)) - (super-new (editor text) (with-border? #f)) + (inherit set-margin + set-inset) - (set-margin 0 0 0 0) - ;;(set-inset 2 2 2 2) - ;;(set-margin 2 2 2 2) - (set-inset 0 0 0 0) + (define text (new text:standard-style-list%)) + (super-new (editor text) (with-border? #f)) - (send text begin-edit-sequence) - (send text change-style (make-object style-delta% 'change-alignment 'top)) - (define display - (print-syntax-to-editor stx text - (send host get-controller) - (send host get-config))) - (send text lock #t) - (send text end-edit-sequence) - (send text hide-caret #t) + (set-margin 0 0 0 0) + ;;(set-inset 2 2 2 2) + ;;(set-margin 2 2 2 2) + (set-inset 0 0 0 0) - (send host add-keymap text this) + (send text begin-edit-sequence) + (send text change-style (make-object style-delta% 'change-alignment 'top)) + (define display + (print-syntax-to-editor stx text controller config)) + (send text lock #t) + (send text end-edit-sequence) + (send text hide-caret #t) - ;; snip% Methods - (define/override (copy) - (new syntax-value-snip% (host host) (syntax stx))) + (setup-keymap text) - ;; read-special : any number/#f number/#f number/#f -> syntax - ;; Produces 3D syntax to preserve eq-ness of syntax - ;; #'#'stx would be lose identity when wrapped - (define/public (read-special src line col pos) - (with-syntax ([p (lambda () stx)]) - #'(p))) - )) + (define/public (setup-keymap text) + (new syntax-keymap% + (controller controller) + (config config) + (editor text))) - (define top-aligned - (make-object style-delta% 'change-alignment 'top)) + ;; snip% Methods + (define/override (copy) + (new syntax-value-snip% + (config config) + (controller controller) + (syntax stx))) - (define-struct styled (contents style clickback)) + ;; read-special : any number/#f number/#f number/#f -> syntax + ;; Produces 3D syntax to preserve eq-ness of syntax + ;; #'#'stx would be lose identity when wrapped + (define/public (read-special src line col pos) + (with-syntax ([p (lambda () stx)]) + #'(p))) + )) - ;; clicky-snip% - (define clicky-snip% - (class* editor-snip% () +(define top-aligned + (make-object style-delta% 'change-alignment 'top)) - (init-field [open-style '(border)] - [closed-style '(tight-text-fit)]) +(define-struct styled (contents style clickback)) - (inherit set-margin - set-inset - set-snipclass - set-tight-text-fit - show-border - get-admin) +;; clicky-snip% +(define clicky-snip% + (class* editor-snip% () - (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) + (init-field [open-style '(border)] + [closed-style '(tight-text-fit)]) - (define/public (closed-contents) null) - (define/public (open-contents) null) + (inherit set-margin + set-inset + set-snipclass + set-tight-text-fit + show-border + get-admin) - (define open? #f) + (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 (refresh-contents) - (send* -outer - (begin-edit-sequence) - (lock #f) - (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)) - (lock #t) - (end-edit-sequence))) + (define/public (closed-contents) null) + (define/public (open-contents) null) - (define/private (do-style style) - (show-border (memq 'border style)) - (set-tight-text-fit (memq 'tight-text-fit style))) + (define open? #f) - (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))))])) + (define/public (refresh-contents) + (send* -outer + (begin-edit-sequence) + (lock #f) + (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)) + (lock #t) + (end-edit-sequence))) - (send -outer hide-caret #t) - (send -outer lock #t) - (refresh-contents) - )) + (define/private (do-style style) + (show-border (memq 'border style)) + (set-tight-text-fit (memq 'tight-text-fit style))) - ;; syntax-snip% - (define syntax-snip% - (class* clicky-snip% (readable-snip<%>) - (init-field ((stx syntax))) - (init-field (host (new dumb-host%))) - (define config (send host get-config)) - (inherit set-snipclass - refresh-contents) + (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))))])) - (define the-syntax-snip - (new syntax-value-snip% - (syntax stx) - (host host))) - (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)) + (send -outer hide-caret #t) + (send -outer lock #t) + (refresh-contents) + )) - (define properties-snip - (new properties-container-snip% - (controller (send host get-controller)))) +;; syntax-snip% +(define syntax-snip% + (class* clicky-snip% (readable-snip<%>) + (init-field ((stx syntax))) + (init-field [controller (new controller%)]) + (init-field [config (new syntax-snip-config%)]) - (define/override (closed-contents) - (list the-summary)) + (inherit set-snipclass + refresh-contents) - (define/override (open-contents) - (list " " - the-syntax-snip - " " - properties-snip)) + (define the-syntax-snip + (new syntax-value-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)) - ;; Snip methods - (define/override (copy) - (new syntax-snip% (syntax stx))) - (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)) + (define properties-snip + (new properties-container-snip% + (controller controller))) - (send config listen-props-shown? - (lambda (?) (refresh-contents))) + (define/override (closed-contents) + (list the-summary)) - (super-new) - (set-snipclass snip-class))) + (define/override (open-contents) + (list " " + the-syntax-snip + " " + properties-snip)) + ;; Snip methods + (define/override (copy) + (new syntax-snip% (syntax stx))) + (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)) - (define properties-container-snip% - (class clicky-snip% - (init controller) + (send config listen-props-shown? + (lambda (?) (refresh-contents))) - (define properties-snip - (new properties-snip% (controller controller))) + (super-new) + (set-snipclass snip-class) + )) - (define/override (open-contents) - (list #;(show-properties-icon) - properties-snip)) +(define properties-container-snip% + (class clicky-snip% + (init controller) - (define/override (closed-contents) - (list (show-properties-icon))) + (define properties-snip + (new properties-snip% (controller controller))) - (super-new (open-style '()) - (closed-style '())))) + (define/override (open-contents) + (list #;(show-properties-icon) + properties-snip)) - (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/override (closed-contents) + (list (show-properties-icon))) - (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"))) + (super-new (open-style '()) + (closed-style '())))) - (define (show-properties-icon) - (make-object image-snip% - (build-path (collection-path "icons") "syncheck.png"))) +(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)) - ;; marshall-syntax : syntax -> printable - (define (marshall-syntax stx) - (unless (syntax? stx) - (error 'marshall-syntax "not syntax: ~s\n" stx)) - `(syntax - (source ,(marshall-object (syntax-source stx))) - (source-module ,(marshall-object (syntax-source-module stx))) - (position ,(syntax-position stx)) - (line ,(syntax-line stx)) - (column ,(syntax-column stx)) - (span ,(syntax-span stx)) - (original? ,(syntax-original? stx)) - (properties - ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x)))) - (syntax-property-symbol-keys stx))) - (contents - ,(marshall-object (syntax-e stx))))) +(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"))) - ;; marshall-object : any -> printable - ;; really only intended for use with marshall-syntax - (define (marshall-object obj) - (cond - [(syntax? obj) (marshall-syntax obj)] - [(pair? obj) - `(pair ,(cons (marshall-object (car obj)) - (marshall-object (cdr obj))))] - [(or (symbol? obj) - (char? obj) - (number? obj) - (string? obj) - (boolean? obj) - (null? obj)) - `(other ,obj)] - [else (string->symbol (format "unknown-object: ~s" obj))])) +(define (show-properties-icon) + (make-object image-snip% + (build-path (collection-path "icons") "syncheck.png"))) - ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss - (define syntax-snipclass% - (class snip-class% - (define/override (read stream) - (make-object syntax-snip% - (unmarshall-syntax (read-from-string (send stream get-bytes))))) - (super-instantiate ()))) +;; marshall-syntax : syntax -> printable +(define (marshall-syntax stx) + (unless (syntax? stx) + (error 'marshall-syntax "not syntax: ~s\n" stx)) + `(syntax + (source ,(marshall-object (syntax-source stx))) + (source-module ,(marshall-object (syntax-source-module stx))) + (position ,(syntax-position stx)) + (line ,(syntax-line stx)) + (column ,(syntax-column stx)) + (span ,(syntax-span stx)) + (original? ,(syntax-original? stx)) + (properties + ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x)))) + (syntax-property-symbol-keys stx))) + (contents + ,(marshall-object (syntax-e stx))))) - (define snip-class (make-object syntax-snipclass%)) - (send snip-class set-version 2) - (send snip-class set-classname - (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser"))) - (send (get-the-snip-class-list) add snip-class) +;; marshall-object : any -> printable +;; really only intended for use with marshall-syntax +(define (marshall-object obj) + (cond + [(syntax? obj) (marshall-syntax obj)] + [(pair? obj) + `(pair ,(cons (marshall-object (car obj)) + (marshall-object (cdr obj))))] + [(or (symbol? obj) + (char? obj) + (number? obj) + (string? obj) + (boolean? obj) + (null? obj)) + `(other ,obj)] + [else (string->symbol (format "unknown-object: ~s" obj))])) - (define (unmarshall-syntax stx) - (match stx - [`(syntax - (source ,src) - (source-module ,source-module) ;; marshalling - (position ,pos) - (line ,line) - (column ,col) - (span ,span) - (original? ,original?) - (properties ,@(properties ...)) - (contents ,contents)) - (foldl - add-properties - (datum->syntax-object - #'here ;; ack - (unmarshall-object contents) - (list (unmarshall-object src) - line - col - pos - span)) - properties)] - [else #'unknown-syntax-object])) - - ;; add-properties : syntax any -> syntax - (define (add-properties prop-spec stx) - (match prop-spec - [`(,(and sym (? symbol?)) - ,prop) - (syntax-property stx sym (unmarshall-object prop))] - [else stx])) - - (define (unmarshall-object obj) - (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))]) - (if (and (pair? obj) - (symbol? (car obj))) - (case (car obj) - [(pair) - (if (pair? (cdr obj)) - (let ([raw-obj (cadr obj)]) - (if (pair? raw-obj) - (cons (unmarshall-object (car raw-obj)) - (unmarshall-object (cdr raw-obj))) - (unknown))) - (unknown))] - [(other) - (if (pair? (cdr obj)) - (cadr obj) - (unknown))] - [(syntax) (unmarshall-syntax obj)] - [else (unknown)]) - (unknown)))) +;; COPIED AND MODIFIED from mrlib/syntax-browser.ss +(define syntax-snipclass% + (class snip-class% + (define/override (read stream) + (make-object syntax-snip% + (unmarshall-syntax (read-from-string (send stream get-bytes))))) + (super-instantiate ()))) - ) +(define snip-class (make-object syntax-snipclass%)) +(send snip-class set-version 2) +(send snip-class set-classname + (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser"))) +(send (get-the-snip-class-list) add snip-class) + +(define (unmarshall-syntax stx) + (match stx + [`(syntax + (source ,src) + (source-module ,source-module) ;; marshalling + (position ,pos) + (line ,line) + (column ,col) + (span ,span) + (original? ,original?) + (properties . ,properties) + (contents ,contents)) + (foldl + add-properties + (datum->syntax + #'here ;; ack + (unmarshall-object contents) + (list (unmarshall-object src) + line + col + pos + span)) + properties)] + [else #'unknown-syntax-object])) + +;; add-properties : syntax any -> syntax +(define (add-properties prop-spec stx) + (match prop-spec + [`(,(and sym (? symbol?)) + ,prop) + (syntax-property stx sym (unmarshall-object prop))] + [else stx])) + +(define (unmarshall-object obj) + (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))]) + (if (and (pair? obj) + (symbol? (car obj))) + (case (car obj) + [(pair) + (if (pair? (cdr obj)) + (let ([raw-obj (cadr obj)]) + (if (pair? raw-obj) + (cons (unmarshall-object (car raw-obj)) + (unmarshall-object (cdr raw-obj))) + (unknown))) + (unknown))] + [(other) + (if (pair? (cdr obj)) + (cadr obj) + (unknown))] + [(syntax) (unmarshall-syntax obj)] + [else (unknown)]) + (unknown)))) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 3d0966c..b1ae668 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -1,11 +1,10 @@ -#lang mzscheme +#lang scheme/base (require scheme/class mred framework/framework scheme/list scheme/match - mzlib/kw syntax/boundmap "interfaces.ss" "controller.ss" @@ -14,7 +13,8 @@ "hrule-snip.ss" "properties.ss" "text.ss" - "util.ss") + "util.ss" + "../util/mpi.ss") (provide widget%) ;; widget% @@ -104,27 +104,27 @@ (send -text set-clickback a b handler) (send -text change-style clickback-style a b))))) - (define/public add-syntax - (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null] - hi2-color [hi2-stxs null]) - (define (get-binder id) - (module-identifier-mapping-get alpha-table id (lambda () #f))) - (when (and (pair? hi-stxs) (not hi-color)) - (error 'syntax-widget%::add-syntax "no highlight color specified")) - (let ([display (internal-add-syntax stx)] - [definite-table (make-hash-table)]) - (when (and hi2-color (pair? hi2-stxs)) - (send display highlight-syntaxes hi2-stxs hi2-color)) - (when (and hi-color (pair? hi-stxs)) - (send display highlight-syntaxes hi-stxs hi-color)) - (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites) - (when alpha-table - (let ([range (send display get-range)] - [start (send display get-start-position)]) - (define (adjust n) (+ start n)) - (for-each - (lambda (id) - #; ;; DISABLED + (define/public (add-syntax stx + #:alpha-table alpha-table + #:definites [definites null] + #:hi-colors [hi-colors null] + #:hi-stxss [hi-stxss null]) + (define (get-binder id) + (module-identifier-mapping-get alpha-table id (lambda () #f))) + (let ([display (internal-add-syntax stx)] + [definite-table (make-hasheq)]) + (for-each (lambda (hi-stxs hi-color) + (send display highlight-syntaxes hi-stxs hi-color)) + hi-stxss + hi-colors) + (for-each (lambda (x) (hash-set! definite-table x #t)) definites) + (when alpha-table + (let ([range (send display get-range)] + [start (send display get-start-position)]) + (define (adjust n) (+ start n)) + (for-each + (lambda (id) + (when #f ;; DISABLED (match (identifier-binding id) [(list src-mod src-name nom-mod nom-name _) (for-each (lambda (id-r) @@ -133,34 +133,33 @@ (adjust (cdr id-r)) (string-append "from " (mpi->string src-mod)) - (if (hash-table-get definite-table id #f) + (if (hash-ref definite-table id #f) "blue" "purple"))) (send range get-ranges id))] - [_ (void)]) - - (let ([binder (get-binder id)]) - (when binder - (for-each - (lambda (binder-r) - (for-each (lambda (id-r) - (if (hash-table-get definite-table id #f) - (send -text add-arrow - (adjust (car binder-r)) - (adjust (cdr binder-r)) - (adjust (car id-r)) - (adjust (cdr id-r)) - "blue") - (send -text add-question-arrow - (adjust (car binder-r)) - (adjust (cdr binder-r)) - (adjust (car id-r)) - (adjust (cdr id-r)) - "purple"))) - (send range get-ranges id))) - (send range get-ranges binder))))) - (send range get-identifier-list)))) - display))) + [_ (void)])) + (let ([binder (get-binder id)]) + (when binder + (for-each + (lambda (binder-r) + (for-each (lambda (id-r) + (if (hash-ref definite-table id #f) + (send -text add-arrow + (adjust (car binder-r)) + (adjust (cdr binder-r)) + (adjust (car id-r)) + (adjust (cdr id-r)) + "blue") + (send -text add-question-arrow + (adjust (car binder-r)) + (adjust (cdr binder-r)) + (adjust (car id-r)) + (adjust (cdr id-r)) + "purple"))) + (send range get-ranges id))) + (send range get-ranges binder))))) + (send range get-identifier-list)))) + display)) (define/public (add-separator) (with-unlock -text diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss new file mode 100644 index 0000000..bf82d49 --- /dev/null +++ b/collects/macro-debugger/view/step-display.ss @@ -0,0 +1,246 @@ + +#lang scheme/base +(require scheme/class + scheme/unit + scheme/list + scheme/match + scheme/gui + framework/framework + syntax/boundmap + "interfaces.ss" + "prefs.ss" + "extensions.ss" + "warning.ss" + "hiding-panel.ss" + "../model/deriv.ss" + "../model/deriv-util.ss" + "../model/deriv-find.ss" + "../model/deriv-parser.ss" + "../model/trace.ss" + "../model/reductions-config.ss" + "../model/reductions.ss" + "../model/steps.ss" + "../util/notify.ss" + "cursor.ss" + "debug-format.ss") +#; +(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<%> + (interface () + ;; add-syntax + add-syntax + + ;; add-step + add-step + + ;; add-error + add-error + + ;; add-final + add-final + + ;; add-internal-error + add-internal-error)) + +(define step-display% + (class* object% (step-display<%>) + + (init-field config) + (init-field ((sbview syntax-widget))) + (super-new) + + (define/public (add-internal-error part exn stx events) + (send sbview add-text + (if part + (format "Macro stepper error (~a)" part) + "Macro stepper error")) + (when (exn? exn) + (send sbview add-text " ") + (send sbview add-clickback "[details]" + (lambda _ (show-internal-error-details exn events)))) + (send sbview add-text ". ") + (when stx (send sbview add-text "Original syntax:")) + (send sbview add-text "\n") + (when stx (send sbview add-syntax stx))) + + (define/private (show-internal-error-details exn events) + (case (message-box/custom "Macro stepper internal error" + (format "Internal error:\n~a" (exn-message exn)) + "Show error" + "Dump debugging file" + "Cancel") + ((1) (queue-callback + (lambda () + (raise exn)))) + ((2) (queue-callback + (lambda () + (let ([file (put-file)]) + (when file + (write-debug-file file exn events)))))) + ((3 #f) (void)))) + + (define/public (add-error exn) + (send sbview add-error-text (exn-message exn)) + (send sbview add-text "\n")) + + (define/public (add-step step + #:binders binders) + (cond [(step? step) + (show-step step binders)] + [(misstep? step) + (show-misstep step binders)] + [(prestep? step) + (show-prestep step binders)] + [(poststep? step) + (show-poststep step binders)])) + + (define/public (add-syntax stx + #:binders binders + #:definites definites) + (send sbview add-syntax stx + #:alpha-table binders + #:definites (or definites null))) + + (define/public (add-final stx error + #:binders binders + #:definites definites) + (when stx + (send sbview add-text "Expansion finished\n") + (send sbview add-syntax stx + #:alpha-table binders + #:definites (or definites null))) + (when error + (add-error error))) + + ;; show-lctx : Step -> void + (define/private (show-lctx step binders) + (define state (protostep-s1 step)) + (define lctx (state-lctx state)) + (when (pair? lctx) + (send sbview add-text "\n") + (for-each (lambda (bf) + (send sbview add-text + "while executing macro transformer in:\n") + (insert-syntax/redex (bigframe-term bf) + (bigframe-foci bf) + binders + (state-uses state) + (state-frontier state))) + (reverse lctx)))) + + ;; separator : Step -> void + (define/private (separator step) + (insert-step-separator (step-type->string (protostep-type step)))) + + ;; separator/small : Step -> void + (define/private (separator/small step) + (insert-step-separator/small + (step-type->string (protostep-type step)))) + + ;; show-step : Step -> void + (define/private (show-step step binders) + (show-state/redex (protostep-s1 step) binders) + (separator step) + (show-state/contractum (step-s2 step) binders) + (show-lctx step binders)) + + (define/private (show-state/redex state binders) + (insert-syntax/redex (state-term state) + (state-foci state) + binders + (state-uses state) + (state-frontier state))) + + (define/private (show-state/contractum state binders) + (insert-syntax/contractum (state-term state) + (state-foci state) + binders + (state-uses state) + (state-frontier state))) + + ;; show-prestep : Step -> void + (define/private (show-prestep step binders) + (separator/small step) + (show-state/redex (protostep-s1 step) binders) + (show-lctx step binders)) + + ;; show-poststep : Step -> void + (define/private (show-poststep step binders) + (separator/small step) + (show-state/contractum (protostep-s1 step) binders) + (show-lctx step binders)) + + ;; show-misstep : Step -> void + (define/private (show-misstep step binders) + (define state (protostep-s1 step)) + (show-state/redex state binders) + (separator step) + (send sbview add-error-text (exn-message (misstep-exn step))) + (send sbview add-text "\n") + (when (exn:fail:syntax? (misstep-exn step)) + (for-each (lambda (e) + (send sbview add-syntax e + #:alpha-table binders + #:definites (or (state-uses state) null))) + (exn:fail:syntax-exprs (misstep-exn step)))) + (show-lctx step binders)) + + ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void + (define/private (insert-syntax/color stx foci binders definites frontier hi-color) + (define highlight-foci? (send config get-highlight-foci?)) + (define highlight-frontier? (send config get-highlight-frontier?)) + (send sbview add-syntax stx + #:definites (or definites null) + #:alpha-table binders + #:hi-colors (list hi-color + "WhiteSmoke") + #:hi-stxss (list (if highlight-foci? foci null) + (if highlight-frontier? frontier null)))) + + ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void + (define/private (insert-syntax/redex stx foci binders definites frontier) + (insert-syntax/color stx foci binders definites frontier "MistyRose")) + + ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void + (define/private (insert-syntax/contractum stx foci binders definites frontier) + (insert-syntax/color stx foci binders definites frontier "LightCyan")) + + ;; insert-step-separator : string -> void + (define/private (insert-step-separator text) + (send sbview add-text "\n ") + (send sbview add-text + (make-object image-snip% + (build-path (collection-path "icons") + "red-arrow.bmp"))) + (send sbview add-text " ") + (send sbview add-text text) + (send sbview add-text "\n\n")) + + ;; insert-as-separator : string -> void + (define/private (insert-as-separator text) + (send sbview add-text "\n ") + (send sbview add-text text) + (send sbview add-text "\n\n")) + + ;; insert-step-separator/small : string -> void + (define/private (insert-step-separator/small text) + (send sbview add-text " ") + (send sbview add-text + (make-object image-snip% + (build-path (collection-path "icons") + "red-arrow.bmp"))) + (send sbview add-text " ") + (send sbview add-text text) + (send sbview add-text "\n\n")) + )) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 830a1c7..640e06e 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -13,6 +13,7 @@ "warning.ss" "hiding-panel.ss" "term-record.ss" + "step-display.ss" "../model/deriv.ss" "../model/deriv-util.ss" "../model/deriv-find.ss" @@ -95,6 +96,7 @@ (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-warnings-area) warnings-area) (define/public (get-macro-hiding-prefs) macro-hiding-prefs) @@ -127,6 +129,9 @@ (define sbview (new stepper-syntax-widget% (parent area) (macro-stepper this))) + (define step-displayer (new step-display% + (config config) + (syntax-widget sbview))) (define sbc (send sbview get-controller)) (define control-pane (new vertical-panel% (parent area) (stretchable-height #f))) diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index 6e08c02..20c155a 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -12,6 +12,7 @@ "extensions.ss" "warning.ss" "hiding-panel.ss" + "step-display.ss" "../model/deriv.ss" "../model/deriv-util.ss" "../model/deriv-find.ss" @@ -26,23 +27,18 @@ (provide term-record%) -;; 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))) - ;; TermRecords (define term-record% (class object% (init-field stepper) - (init-field [events #f]) (define config (send stepper get-config)) - (define sbview (send stepper get-view)) + (define displayer (send stepper get-step-displayer)) + + ;; Data + + (init-field [events #f]) (init-field [raw-deriv #f]) (define raw-deriv-oops #f) @@ -52,13 +48,15 @@ (define binders #f) (define raw-steps #f) - (define raw-steps-estx #f) - (define definites #f) - (define error #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-definites #f) (define raw-steps-oops #f) (define steps #f) + ;; -- + (define steps-position #f) (super-new) @@ -76,8 +74,8 @@ [get-deriv-hidden? deriv-hidden?] [get-binders binders]) (define-guarded-getters (recache-raw-steps!) - [get-definites definites] - [get-error error] + [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]) @@ -92,8 +90,8 @@ (invalidate-steps!) (set! raw-steps #f) (set! raw-steps-estx #f) - (set! definites #f) - (set! error #f) + (set! raw-steps-exn #f) + (set! raw-steps-definites #f) (set! raw-steps-oops #f)) ;; invalidate-synth! : -> void @@ -158,8 +156,8 @@ (reductions+ deriv))]) (set! raw-steps raw-steps*) (set! raw-steps-estx estx*) - (set! error error*) - (set! definites definites*))))))) + (set! raw-steps-exn error*) + (set! raw-steps-definites definites*))))))) ;; recache-steps! : -> void (define/private (recache-steps!) @@ -271,20 +269,18 @@ ;; display-initial-term : -> void (define/public (display-initial-term) - (add-syntax (wderiv-e1 deriv) #f null)) + (send displayer add-syntax (wderiv-e1 deriv) #f null)) ;; display-final-term : -> void (define/public (display-final-term) (recache-steps!) (cond [(syntax? raw-steps-estx) - (add-syntax raw-steps-estx binders definites)] - [(exn? error) - (add-error error)] - [raw-steps-oops - (add-internal-error "steps" raw-steps-oops #f)] - [else - (error 'term-record::display-final-term - "internal error")])) + (send displayer add-syntax raw-steps-estx + #:binders binders + #:definites raw-steps-definites)] + [(exn? raw-steps-exn) + (send displayer add-error raw-steps-exn)] + [else (display-oops #f)])) ;; display-step : -> void (define/public (display-step) @@ -292,191 +288,23 @@ (cond [steps (let ([step (cursor:next steps)]) (if step - (add-step step binders) - (add-final raw-steps-estx error binders definites)))] - [raw-steps-oops - (add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))] + (send displayer add-step step + #:binders binders) + (send displayer add-final raw-steps-estx raw-steps-exn + #:binders binders + #:definites raw-steps-definites)))] + [else (display-oops #t)])) + + ;; display-oops : boolean -> void + (define/private (display-oops show-syntax?) + (cond [raw-steps-oops + (send displayer add-internal-error + "steps" raw-steps-oops + (and show-syntax? (wderiv-e1 deriv)) + events)] [raw-deriv-oops - (add-internal-error "derivation" raw-deriv-oops #f)] + (send displayer add-internal-error + "derivation" raw-deriv-oops #f events)] [else - (add-internal-error "derivation" #f)])) - - (define/public (add-internal-error part exn stx) - (send sbview add-text - (if part - (format "Macro stepper error (~a)" part) - "Macro stepper error")) - (when (exn? exn) - (send sbview add-text " ") - (send sbview add-clickback "[details]" - (lambda _ (show-internal-error-details exn)))) - (send sbview add-text ". ") - (when stx (send sbview add-text "Original syntax:")) - (send sbview add-text "\n") - (when stx (send sbview add-syntax stx))) - - (define/private (show-internal-error-details exn) - (case (message-box/custom "Macro stepper internal error" - (format "Internal error:\n~a" (exn-message exn)) - "Show error" - "Dump debugging file" - "Cancel") - ((1) (queue-callback - (lambda () - (raise exn)))) - ((2) (queue-callback - (lambda () - (let ([file (put-file)]) - (when file - (write-debug-file file exn events)))))) - ((3 #f) (void)))) - - (define/public (add-error exn) - (send sbview add-error-text (exn-message exn)) - (send sbview add-text "\n")) - - (define/public (add-step step binders) - (cond [(step? step) - (show-step step binders)] - [(misstep? step) - (show-misstep step binders)] - [(prestep? step) - (show-prestep step binders)] - [(poststep? step) - (show-poststep step binders)])) - - (define/public (add-syntax stx binders definites) - (send sbview add-syntax stx - '#:alpha-table binders - '#:definites (or definites null))) - - (define/private (add-final stx error binders definites) - (when stx - (send sbview add-text "Expansion finished\n") - (send sbview add-syntax stx - '#:alpha-table binders - '#:definites (or definites null))) - (when error - (add-error error))) - - ;; show-lctx : Step -> void - (define/private (show-lctx step binders) - (define state (protostep-s1 step)) - (define lctx (state-lctx state)) - (when (pair? lctx) - (send sbview add-text "\n") - (for-each (lambda (bf) - (send sbview add-text - "while executing macro transformer in:\n") - (insert-syntax/redex (bigframe-term bf) - (bigframe-foci bf) - binders - (state-uses state) - (state-frontier state))) - (reverse lctx)))) - - ;; separator : Step -> void - (define/private (separator step) - (insert-step-separator (step-type->string (protostep-type step)))) - - ;; separator/small : Step -> void - (define/private (separator/small step) - (insert-step-separator/small - (step-type->string (protostep-type step)))) - - ;; show-step : Step -> void - (define/private (show-step step binders) - (show-state/redex (protostep-s1 step) binders) - (separator step) - (show-state/contractum (step-s2 step) binders) - (show-lctx step binders)) - - (define/private (show-state/redex state binders) - (insert-syntax/contractum (state-term state) - (state-foci state) - binders - (state-uses state) - (state-frontier state))) - - (define/private (show-state/contractum state binders) - (insert-syntax/contractum (state-term state) - (state-foci state) - binders - (state-uses state) - (state-frontier state))) - - ;; show-prestep : Step -> void - (define/private (show-prestep step binders) - (separator/small step) - (show-state/redex (protostep-s1 step) binders) - (show-lctx step binders)) - - ;; show-poststep : Step -> void - (define/private (show-poststep step binders) - (separator/small step) - (show-state/contractum (protostep-s1 step) binders) - (show-lctx step binders)) - - ;; show-misstep : Step -> void - (define/private (show-misstep step binders) - (define state (protostep-s1 step)) - (show-state/redex state binders) - (separator step) - (send sbview add-error-text (exn-message (misstep-exn step))) - (send sbview add-text "\n") - (when (exn:fail:syntax? (misstep-exn step)) - (for-each (lambda (e) - (send sbview add-syntax e - '#:alpha-table binders - '#:definites (or (state-uses state) null))) - (exn:fail:syntax-exprs (misstep-exn step)))) - (show-lctx step binders)) - - ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void - (define/private (insert-syntax/color stx foci binders definites frontier hi-color) - (send sbview add-syntax stx - '#:definites (or definites null) - '#:alpha-table binders - '#:hi-color hi-color - '#:hi-stxs (if (send config get-highlight-foci?) foci null) - '#:hi2-color "WhiteSmoke" - '#:hi2-stxs (if (send config get-highlight-frontier?) frontier null))) - - ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void - (define/private (insert-syntax/redex stx foci binders definites frontier) - (insert-syntax/color stx foci binders definites frontier "MistyRose")) - - ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void - (define/private (insert-syntax/contractum stx foci binders definites frontier) - (insert-syntax/color stx foci binders definites frontier "LightCyan")) - - ;; insert-step-separator : string -> void - (define/private (insert-step-separator text) - (send sbview add-text "\n ") - (send sbview add-text - (make-object image-snip% - (build-path (collection-path "icons") - "red-arrow.bmp"))) - (send sbview add-text " ") - (send sbview add-text text) - (send sbview add-text "\n\n")) - - ;; insert-as-separator : string -> void - (define/private (insert-as-separator text) - (send sbview add-text "\n ") - (send sbview add-text text) - (send sbview add-text "\n\n")) - - ;; insert-step-separator/small : string -> void - (define/private (insert-step-separator/small text) - (send sbview add-text " ") - (send sbview add-text - (make-object image-snip% - (build-path (collection-path "icons") - "red-arrow.bmp"))) - (send sbview add-text " ") - (send sbview add-text text) - (send sbview add-text "\n\n")) - - + (error 'term-record::display-oops "internal error")])) ))