commit c715df4d97c510ae273cb1a0f21ef81556de4c9a
parent fdd704dd9e75f30da2f5bd79502e0a52a9c745bb
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sat, 13 Dec 2008 07:49:52 +0000
macro debugger: reorg, minor bug fixes
svn: r12825
original commit: 12216b15aaabdc69615ec38a5886c90579af6718
Diffstat:
6 files changed, 705 insertions(+), 626 deletions(-)
diff --git 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
@@ -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")
-
- (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 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))))))
-
- ;; 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)
-
- (define text (new text:standard-style-list%))
- (super-new (editor text) (with-border? #f))
-
- (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 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)
-
- (send host add-keymap text this)
-
- ;; snip% Methods
- (define/override (copy)
- (new syntax-value-snip% (host host) (syntax stx)))
-
- ;; 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 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)
- (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/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)
- ))
-
- ;; 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 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))
-
- (define properties-snip
- (new properties-container-snip%
- (controller (send host get-controller))))
-
- (define/override (closed-contents)
- (list the-summary))
-
- (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))
-
- (send 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")))
-
- ;; 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)))))
-
- ;; 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))]))
-
- ;; 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-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))))
-
- )
+#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%)
+
+(define syntax-snip-config-base%
+ (class prefs-base%
+ (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)))
+
+;; 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%)))
+
+ (inherit set-margin
+ set-inset)
+
+ (define text (new text:standard-style-list%))
+ (super-new (editor text) (with-border? #f))
+
+ (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 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)
+
+ (setup-keymap text)
+
+ (define/public (setup-keymap text)
+ (new syntax-keymap%
+ (controller controller)
+ (config config)
+ (editor text)))
+
+ ;; snip% Methods
+ (define/override (copy)
+ (new syntax-value-snip%
+ (config config)
+ (controller controller)
+ (syntax stx)))
+
+ ;; 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 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)
+ (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/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)
+ ))
+
+;; 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%)])
+
+ (inherit set-snipclass
+ refresh-contents)
+
+ (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))
+
+ (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 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))
+
+ (send 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")))
+
+;; 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)))))
+
+;; 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))]))
+
+;; 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
@@ -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
@@ -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
@@ -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
@@ -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")]))
))
