macro debugger: reorg, minor bug fixes
svn: r12825 original commit: 12216b15aaabdc69615ec38a5886c90579af6718
This commit is contained in:
Ryan Culpepper
parent
fdd704dd9e
commit
c715df4d97
|
|
@ -5,7 +5,8 @@
|
||||||
"interfaces.ss"
|
"interfaces.ss"
|
||||||
"../util/notify.ss"
|
"../util/notify.ss"
|
||||||
"../util/misc.ss")
|
"../util/misc.ss")
|
||||||
(provide syntax-prefs-base%
|
(provide prefs-base%
|
||||||
|
syntax-prefs-base%
|
||||||
syntax-prefs%
|
syntax-prefs%
|
||||||
syntax-prefs/readonly%)
|
syntax-prefs/readonly%)
|
||||||
|
|
||||||
|
|
@ -19,7 +20,7 @@
|
||||||
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
|
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
|
||||||
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
|
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
|
||||||
|
|
||||||
(define syntax-prefs-base%
|
(define prefs-base%
|
||||||
(class object%
|
(class object%
|
||||||
;; columns : number
|
;; columns : number
|
||||||
(field/notify columns (new notify-box% (value 60)))
|
(field/notify columns (new notify-box% (value 60)))
|
||||||
|
|
@ -41,6 +42,10 @@
|
||||||
"indigo" "purple"
|
"indigo" "purple"
|
||||||
"orange" "salmon" "darkgoldenrod" "olive"))))
|
"orange" "salmon" "darkgoldenrod" "olive"))))
|
||||||
|
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
(define syntax-prefs-base%
|
||||||
|
(class prefs-base%
|
||||||
;; width, height : number
|
;; width, height : number
|
||||||
(notify-methods width)
|
(notify-methods width)
|
||||||
(notify-methods height)
|
(notify-methods height)
|
||||||
|
|
|
||||||
|
|
@ -1,363 +1,359 @@
|
||||||
|
|
||||||
(module syntax-snip mzscheme
|
#lang scheme/base
|
||||||
(require mzlib/class
|
(require scheme/class
|
||||||
mred
|
scheme/match
|
||||||
framework
|
scheme/list
|
||||||
mzlib/match
|
mzlib/string
|
||||||
mzlib/list
|
mred
|
||||||
mzlib/string
|
framework
|
||||||
"../util/notify.ss"
|
"../util/notify.ss"
|
||||||
"interfaces.ss"
|
"interfaces.ss"
|
||||||
"display.ss"
|
"display.ss"
|
||||||
"controller.ss"
|
"controller.ss"
|
||||||
"keymap.ss"
|
"keymap.ss"
|
||||||
"properties.ss"
|
"properties.ss"
|
||||||
"partition.ss"
|
"partition.ss"
|
||||||
"prefs.ss")
|
"prefs.ss")
|
||||||
|
|
||||||
(provide syntax-snip%
|
(provide syntax-snip%
|
||||||
syntax-value-snip%)
|
syntax-value-snip%)
|
||||||
|
|
||||||
(define syntax-snip-config-base%
|
(define syntax-snip-config-base%
|
||||||
(class object%
|
(class prefs-base%
|
||||||
(notify-methods props-shown?)
|
(notify-methods props-shown?)
|
||||||
(super-new)))
|
(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%
|
(define syntax-snip-config%
|
||||||
(class object%
|
(class syntax-snip-config-base%
|
||||||
(define controller (new controller%))
|
(define/override (init-props-shown?) (new notify-box% (value #f)))
|
||||||
(define config (new syntax-snip-config%))
|
(super-new)))
|
||||||
(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%
|
;; syntax-value-snip%
|
||||||
(define syntax-value-snip%
|
(define syntax-value-snip%
|
||||||
(class* editor-snip% (readable-snip<%>)
|
(class* editor-snip% (readable-snip<%>)
|
||||||
(init-field ((stx syntax)))
|
(init-field ((stx syntax)))
|
||||||
(init-field (host (new dumb-host%)))
|
(init-field (controller (new controller%)))
|
||||||
(inherit set-margin
|
(init-field (config (new syntax-snip-config%)))
|
||||||
set-inset)
|
|
||||||
|
|
||||||
(define text (new text:standard-style-list%))
|
(inherit set-margin
|
||||||
(super-new (editor text) (with-border? #f))
|
set-inset)
|
||||||
|
|
||||||
(set-margin 0 0 0 0)
|
(define text (new text:standard-style-list%))
|
||||||
;;(set-inset 2 2 2 2)
|
(super-new (editor text) (with-border? #f))
|
||||||
;;(set-margin 2 2 2 2)
|
|
||||||
(set-inset 0 0 0 0)
|
|
||||||
|
|
||||||
(send text begin-edit-sequence)
|
(set-margin 0 0 0 0)
|
||||||
(send text change-style (make-object style-delta% 'change-alignment 'top))
|
;;(set-inset 2 2 2 2)
|
||||||
(define display
|
;;(set-margin 2 2 2 2)
|
||||||
(print-syntax-to-editor stx text
|
(set-inset 0 0 0 0)
|
||||||
(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)
|
(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
|
(setup-keymap text)
|
||||||
(define/override (copy)
|
|
||||||
(new syntax-value-snip% (host host) (syntax stx)))
|
|
||||||
|
|
||||||
;; read-special : any number/#f number/#f number/#f -> syntax
|
(define/public (setup-keymap text)
|
||||||
;; Produces 3D syntax to preserve eq-ness of syntax
|
(new syntax-keymap%
|
||||||
;; #'#'stx would be lose identity when wrapped
|
(controller controller)
|
||||||
(define/public (read-special src line col pos)
|
(config config)
|
||||||
(with-syntax ([p (lambda () stx)])
|
(editor text)))
|
||||||
#'(p)))
|
|
||||||
))
|
|
||||||
|
|
||||||
(define top-aligned
|
;; snip% Methods
|
||||||
(make-object style-delta% 'change-alignment 'top))
|
(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 top-aligned
|
||||||
(define clicky-snip%
|
(make-object style-delta% 'change-alignment 'top))
|
||||||
(class* editor-snip% ()
|
|
||||||
|
|
||||||
(init-field [open-style '(border)]
|
(define-struct styled (contents style clickback))
|
||||||
[closed-style '(tight-text-fit)])
|
|
||||||
|
|
||||||
(inherit set-margin
|
;; clicky-snip%
|
||||||
set-inset
|
(define clicky-snip%
|
||||||
set-snipclass
|
(class* editor-snip% ()
|
||||||
set-tight-text-fit
|
|
||||||
show-border
|
|
||||||
get-admin)
|
|
||||||
|
|
||||||
(define -outer (new text%))
|
(init-field [open-style '(border)]
|
||||||
(super-new (editor -outer) (with-border? #f))
|
[closed-style '(tight-text-fit)])
|
||||||
(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)
|
(inherit set-margin
|
||||||
(define/public (open-contents) null)
|
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)
|
(define/public (closed-contents) null)
|
||||||
(send* -outer
|
(define/public (open-contents) null)
|
||||||
(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)
|
(define open? #f)
|
||||||
(show-border (memq 'border style))
|
|
||||||
(set-tight-text-fit (memq 'tight-text-fit style)))
|
|
||||||
|
|
||||||
(define/private outer:insert
|
(define/public (refresh-contents)
|
||||||
(case-lambda
|
(send* -outer
|
||||||
[(obj)
|
(begin-edit-sequence)
|
||||||
(if (styled? obj)
|
(lock #f)
|
||||||
(outer:insert (styled-contents obj)
|
(erase))
|
||||||
(styled-style obj)
|
(do-style (if open? open-style closed-style))
|
||||||
(styled-clickback obj))
|
(outer:insert (if open? (hide-icon) (show-icon))
|
||||||
(outer:insert obj style:normal))]
|
style:hyper
|
||||||
[(text style)
|
(if open?
|
||||||
(outer:insert text style #f)]
|
(lambda _
|
||||||
[(text style clickback)
|
(set! open? #f)
|
||||||
(let ([start (send -outer last-position)])
|
(refresh-contents))
|
||||||
(send -outer insert text)
|
(lambda _
|
||||||
(let ([end (send -outer last-position)])
|
(set! open? #t)
|
||||||
(send -outer change-style style start end #f)
|
(refresh-contents))))
|
||||||
(when clickback
|
(for-each (lambda (s) (outer:insert s))
|
||||||
(send -outer set-clickback start end clickback))))]))
|
(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)
|
(define/private (do-style style)
|
||||||
(send -outer lock #t)
|
(show-border (memq 'border style))
|
||||||
(refresh-contents)
|
(set-tight-text-fit (memq 'tight-text-fit style)))
|
||||||
))
|
|
||||||
|
|
||||||
;; syntax-snip%
|
(define/private outer:insert
|
||||||
(define syntax-snip%
|
(case-lambda
|
||||||
(class* clicky-snip% (readable-snip<%>)
|
[(obj)
|
||||||
(init-field ((stx syntax)))
|
(if (styled? obj)
|
||||||
(init-field (host (new dumb-host%)))
|
(outer:insert (styled-contents obj)
|
||||||
(define config (send host get-config))
|
(styled-style obj)
|
||||||
(inherit set-snipclass
|
(styled-clickback obj))
|
||||||
refresh-contents)
|
(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
|
(send -outer hide-caret #t)
|
||||||
(new syntax-value-snip%
|
(send -outer lock #t)
|
||||||
(syntax stx)
|
(refresh-contents)
|
||||||
(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
|
;; syntax-snip%
|
||||||
(new properties-container-snip%
|
(define syntax-snip%
|
||||||
(controller (send host get-controller))))
|
(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)
|
(inherit set-snipclass
|
||||||
(list the-summary))
|
refresh-contents)
|
||||||
|
|
||||||
(define/override (open-contents)
|
(define the-syntax-snip
|
||||||
(list " "
|
(new syntax-value-snip%
|
||||||
the-syntax-snip
|
(syntax stx)
|
||||||
" "
|
(controller controller)
|
||||||
properties-snip))
|
(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 properties-snip
|
||||||
(define/override (copy)
|
(new properties-container-snip%
|
||||||
(new syntax-snip% (syntax stx)))
|
(controller controller)))
|
||||||
(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?
|
(define/override (closed-contents)
|
||||||
(lambda (?) (refresh-contents)))
|
(list the-summary))
|
||||||
|
|
||||||
(super-new)
|
(define/override (open-contents)
|
||||||
(set-snipclass snip-class)))
|
(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%
|
(send config listen-props-shown?
|
||||||
(class clicky-snip%
|
(lambda (?) (refresh-contents)))
|
||||||
(init controller)
|
|
||||||
|
|
||||||
(define properties-snip
|
(super-new)
|
||||||
(new properties-snip% (controller controller)))
|
(set-snipclass snip-class)
|
||||||
|
))
|
||||||
|
|
||||||
(define/override (open-contents)
|
(define properties-container-snip%
|
||||||
(list #;(show-properties-icon)
|
(class clicky-snip%
|
||||||
properties-snip))
|
(init controller)
|
||||||
|
|
||||||
(define/override (closed-contents)
|
(define properties-snip
|
||||||
(list (show-properties-icon)))
|
(new properties-snip% (controller controller)))
|
||||||
|
|
||||||
(super-new (open-style '())
|
(define/override (open-contents)
|
||||||
(closed-style '()))))
|
(list #;(show-properties-icon)
|
||||||
|
properties-snip))
|
||||||
|
|
||||||
(define style:normal (make-object style-delta% 'change-normal))
|
(define/override (closed-contents)
|
||||||
(define style:hyper
|
(list (show-properties-icon)))
|
||||||
(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)
|
(super-new (open-style '())
|
||||||
(make-object image-snip%
|
(closed-style '()))))
|
||||||
(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)
|
(define style:normal (make-object style-delta% 'change-normal))
|
||||||
(make-object image-snip%
|
(define style:hyper
|
||||||
(build-path (collection-path "icons") "syncheck.png")))
|
(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 (show-icon)
|
||||||
(define (marshall-syntax stx)
|
(make-object image-snip%
|
||||||
(unless (syntax? stx)
|
(build-path (collection-path "icons") "turn-up.png")))
|
||||||
(error 'marshall-syntax "not syntax: ~s\n" stx))
|
(define (hide-icon)
|
||||||
`(syntax
|
(make-object image-snip%
|
||||||
(source ,(marshall-object (syntax-source stx)))
|
(build-path (collection-path "icons") "turn-down.png")))
|
||||||
(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
|
(define (show-properties-icon)
|
||||||
;; really only intended for use with marshall-syntax
|
(make-object image-snip%
|
||||||
(define (marshall-object obj)
|
(build-path (collection-path "icons") "syncheck.png")))
|
||||||
(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
|
;; marshall-syntax : syntax -> printable
|
||||||
(define syntax-snipclass%
|
(define (marshall-syntax stx)
|
||||||
(class snip-class%
|
(unless (syntax? stx)
|
||||||
(define/override (read stream)
|
(error 'marshall-syntax "not syntax: ~s\n" stx))
|
||||||
(make-object syntax-snip%
|
`(syntax
|
||||||
(unmarshall-syntax (read-from-string (send stream get-bytes)))))
|
(source ,(marshall-object (syntax-source stx)))
|
||||||
(super-instantiate ())))
|
(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%))
|
;; marshall-object : any -> printable
|
||||||
(send snip-class set-version 2)
|
;; really only intended for use with marshall-syntax
|
||||||
(send snip-class set-classname
|
(define (marshall-object obj)
|
||||||
(format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
|
(cond
|
||||||
(send (get-the-snip-class-list) add snip-class)
|
[(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)
|
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
|
||||||
(match stx
|
(define syntax-snipclass%
|
||||||
[`(syntax
|
(class snip-class%
|
||||||
(source ,src)
|
(define/override (read stream)
|
||||||
(source-module ,source-module) ;; marshalling
|
(make-object syntax-snip%
|
||||||
(position ,pos)
|
(unmarshall-syntax (read-from-string (send stream get-bytes)))))
|
||||||
(line ,line)
|
(super-instantiate ())))
|
||||||
(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))))
|
|
||||||
|
|
||||||
)
|
(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))))
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,10 @@
|
||||||
|
|
||||||
#lang mzscheme
|
#lang scheme/base
|
||||||
(require scheme/class
|
(require scheme/class
|
||||||
mred
|
mred
|
||||||
framework/framework
|
framework/framework
|
||||||
scheme/list
|
scheme/list
|
||||||
scheme/match
|
scheme/match
|
||||||
mzlib/kw
|
|
||||||
syntax/boundmap
|
syntax/boundmap
|
||||||
"interfaces.ss"
|
"interfaces.ss"
|
||||||
"controller.ss"
|
"controller.ss"
|
||||||
|
|
@ -14,7 +13,8 @@
|
||||||
"hrule-snip.ss"
|
"hrule-snip.ss"
|
||||||
"properties.ss"
|
"properties.ss"
|
||||||
"text.ss"
|
"text.ss"
|
||||||
"util.ss")
|
"util.ss"
|
||||||
|
"../util/mpi.ss")
|
||||||
(provide widget%)
|
(provide widget%)
|
||||||
|
|
||||||
;; widget%
|
;; widget%
|
||||||
|
|
@ -104,27 +104,27 @@
|
||||||
(send -text set-clickback a b handler)
|
(send -text set-clickback a b handler)
|
||||||
(send -text change-style clickback-style a b)))))
|
(send -text change-style clickback-style a b)))))
|
||||||
|
|
||||||
(define/public add-syntax
|
(define/public (add-syntax stx
|
||||||
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
|
#:alpha-table alpha-table
|
||||||
hi2-color [hi2-stxs null])
|
#:definites [definites null]
|
||||||
(define (get-binder id)
|
#:hi-colors [hi-colors null]
|
||||||
(module-identifier-mapping-get alpha-table id (lambda () #f)))
|
#:hi-stxss [hi-stxss null])
|
||||||
(when (and (pair? hi-stxs) (not hi-color))
|
(define (get-binder id)
|
||||||
(error 'syntax-widget%::add-syntax "no highlight color specified"))
|
(module-identifier-mapping-get alpha-table id (lambda () #f)))
|
||||||
(let ([display (internal-add-syntax stx)]
|
(let ([display (internal-add-syntax stx)]
|
||||||
[definite-table (make-hash-table)])
|
[definite-table (make-hasheq)])
|
||||||
(when (and hi2-color (pair? hi2-stxs))
|
(for-each (lambda (hi-stxs hi-color)
|
||||||
(send display highlight-syntaxes hi2-stxs hi2-color))
|
(send display highlight-syntaxes hi-stxs hi-color))
|
||||||
(when (and hi-color (pair? hi-stxs))
|
hi-stxss
|
||||||
(send display highlight-syntaxes hi-stxs hi-color))
|
hi-colors)
|
||||||
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
|
(for-each (lambda (x) (hash-set! definite-table x #t)) definites)
|
||||||
(when alpha-table
|
(when alpha-table
|
||||||
(let ([range (send display get-range)]
|
(let ([range (send display get-range)]
|
||||||
[start (send display get-start-position)])
|
[start (send display get-start-position)])
|
||||||
(define (adjust n) (+ start n))
|
(define (adjust n) (+ start n))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (id)
|
(lambda (id)
|
||||||
#; ;; DISABLED
|
(when #f ;; DISABLED
|
||||||
(match (identifier-binding id)
|
(match (identifier-binding id)
|
||||||
[(list src-mod src-name nom-mod nom-name _)
|
[(list src-mod src-name nom-mod nom-name _)
|
||||||
(for-each (lambda (id-r)
|
(for-each (lambda (id-r)
|
||||||
|
|
@ -133,34 +133,33 @@
|
||||||
(adjust (cdr id-r))
|
(adjust (cdr id-r))
|
||||||
(string-append "from "
|
(string-append "from "
|
||||||
(mpi->string src-mod))
|
(mpi->string src-mod))
|
||||||
(if (hash-table-get definite-table id #f)
|
(if (hash-ref definite-table id #f)
|
||||||
"blue"
|
"blue"
|
||||||
"purple")))
|
"purple")))
|
||||||
(send range get-ranges id))]
|
(send range get-ranges id))]
|
||||||
[_ (void)])
|
[_ (void)]))
|
||||||
|
(let ([binder (get-binder id)])
|
||||||
(let ([binder (get-binder id)])
|
(when binder
|
||||||
(when binder
|
(for-each
|
||||||
(for-each
|
(lambda (binder-r)
|
||||||
(lambda (binder-r)
|
(for-each (lambda (id-r)
|
||||||
(for-each (lambda (id-r)
|
(if (hash-ref definite-table id #f)
|
||||||
(if (hash-table-get definite-table id #f)
|
(send -text add-arrow
|
||||||
(send -text add-arrow
|
(adjust (car binder-r))
|
||||||
(adjust (car binder-r))
|
(adjust (cdr binder-r))
|
||||||
(adjust (cdr binder-r))
|
(adjust (car id-r))
|
||||||
(adjust (car id-r))
|
(adjust (cdr id-r))
|
||||||
(adjust (cdr id-r))
|
"blue")
|
||||||
"blue")
|
(send -text add-question-arrow
|
||||||
(send -text add-question-arrow
|
(adjust (car binder-r))
|
||||||
(adjust (car binder-r))
|
(adjust (cdr binder-r))
|
||||||
(adjust (cdr binder-r))
|
(adjust (car id-r))
|
||||||
(adjust (car id-r))
|
(adjust (cdr id-r))
|
||||||
(adjust (cdr id-r))
|
"purple")))
|
||||||
"purple")))
|
(send range get-ranges id)))
|
||||||
(send range get-ranges id)))
|
(send range get-ranges binder)))))
|
||||||
(send range get-ranges binder)))))
|
(send range get-identifier-list))))
|
||||||
(send range get-identifier-list))))
|
display))
|
||||||
display)))
|
|
||||||
|
|
||||||
(define/public (add-separator)
|
(define/public (add-separator)
|
||||||
(with-unlock -text
|
(with-unlock -text
|
||||||
|
|
|
||||||
246
collects/macro-debugger/view/step-display.ss
Normal file
246
collects/macro-debugger/view/step-display.ss
Normal file
|
|
@ -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"))
|
||||||
|
))
|
||||||
|
|
@ -13,6 +13,7 @@
|
||||||
"warning.ss"
|
"warning.ss"
|
||||||
"hiding-panel.ss"
|
"hiding-panel.ss"
|
||||||
"term-record.ss"
|
"term-record.ss"
|
||||||
|
"step-display.ss"
|
||||||
"../model/deriv.ss"
|
"../model/deriv.ss"
|
||||||
"../model/deriv-util.ss"
|
"../model/deriv-util.ss"
|
||||||
"../model/deriv-find.ss"
|
"../model/deriv-find.ss"
|
||||||
|
|
@ -95,6 +96,7 @@
|
||||||
(define/public (get-config) config)
|
(define/public (get-config) config)
|
||||||
(define/public (get-controller) sbc)
|
(define/public (get-controller) sbc)
|
||||||
(define/public (get-view) sbview)
|
(define/public (get-view) sbview)
|
||||||
|
(define/public (get-step-displayer) step-displayer)
|
||||||
(define/public (get-warnings-area) warnings-area)
|
(define/public (get-warnings-area) warnings-area)
|
||||||
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
||||||
|
|
||||||
|
|
@ -127,6 +129,9 @@
|
||||||
(define sbview (new stepper-syntax-widget%
|
(define sbview (new stepper-syntax-widget%
|
||||||
(parent area)
|
(parent area)
|
||||||
(macro-stepper this)))
|
(macro-stepper this)))
|
||||||
|
(define step-displayer (new step-display%
|
||||||
|
(config config)
|
||||||
|
(syntax-widget sbview)))
|
||||||
(define sbc (send sbview get-controller))
|
(define sbc (send sbview get-controller))
|
||||||
(define control-pane
|
(define control-pane
|
||||||
(new vertical-panel% (parent area) (stretchable-height #f)))
|
(new vertical-panel% (parent area) (stretchable-height #f)))
|
||||||
|
|
|
||||||
|
|
@ -12,6 +12,7 @@
|
||||||
"extensions.ss"
|
"extensions.ss"
|
||||||
"warning.ss"
|
"warning.ss"
|
||||||
"hiding-panel.ss"
|
"hiding-panel.ss"
|
||||||
|
"step-display.ss"
|
||||||
"../model/deriv.ss"
|
"../model/deriv.ss"
|
||||||
"../model/deriv-util.ss"
|
"../model/deriv-util.ss"
|
||||||
"../model/deriv-find.ss"
|
"../model/deriv-find.ss"
|
||||||
|
|
@ -26,23 +27,18 @@
|
||||||
|
|
||||||
(provide term-record%)
|
(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
|
;; TermRecords
|
||||||
|
|
||||||
(define term-record%
|
(define term-record%
|
||||||
(class object%
|
(class object%
|
||||||
(init-field stepper)
|
(init-field stepper)
|
||||||
(init-field [events #f])
|
|
||||||
|
|
||||||
(define config (send stepper get-config))
|
(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])
|
(init-field [raw-deriv #f])
|
||||||
(define raw-deriv-oops #f)
|
(define raw-deriv-oops #f)
|
||||||
|
|
@ -52,13 +48,15 @@
|
||||||
(define binders #f)
|
(define binders #f)
|
||||||
|
|
||||||
(define raw-steps #f)
|
(define raw-steps #f)
|
||||||
(define raw-steps-estx #f)
|
(define raw-steps-estx #f) ;; #f if raw-steps-exn is exn
|
||||||
(define definites #f)
|
(define raw-steps-exn #f) ;; #f if raw-steps-estx is syntax
|
||||||
(define error #f)
|
(define raw-steps-definites #f)
|
||||||
(define raw-steps-oops #f)
|
(define raw-steps-oops #f)
|
||||||
|
|
||||||
(define steps #f)
|
(define steps #f)
|
||||||
|
|
||||||
|
;; --
|
||||||
|
|
||||||
(define steps-position #f)
|
(define steps-position #f)
|
||||||
|
|
||||||
(super-new)
|
(super-new)
|
||||||
|
|
@ -76,8 +74,8 @@
|
||||||
[get-deriv-hidden? deriv-hidden?]
|
[get-deriv-hidden? deriv-hidden?]
|
||||||
[get-binders binders])
|
[get-binders binders])
|
||||||
(define-guarded-getters (recache-raw-steps!)
|
(define-guarded-getters (recache-raw-steps!)
|
||||||
[get-definites definites]
|
[get-raw-steps-definites raw-steps-definites]
|
||||||
[get-error error]
|
[get-raw-steps-exn raw-steps-exn]
|
||||||
[get-raw-steps-oops raw-steps-oops])
|
[get-raw-steps-oops raw-steps-oops])
|
||||||
(define-guarded-getters (recache-steps!)
|
(define-guarded-getters (recache-steps!)
|
||||||
[get-steps steps])
|
[get-steps steps])
|
||||||
|
|
@ -92,8 +90,8 @@
|
||||||
(invalidate-steps!)
|
(invalidate-steps!)
|
||||||
(set! raw-steps #f)
|
(set! raw-steps #f)
|
||||||
(set! raw-steps-estx #f)
|
(set! raw-steps-estx #f)
|
||||||
(set! definites #f)
|
(set! raw-steps-exn #f)
|
||||||
(set! error #f)
|
(set! raw-steps-definites #f)
|
||||||
(set! raw-steps-oops #f))
|
(set! raw-steps-oops #f))
|
||||||
|
|
||||||
;; invalidate-synth! : -> void
|
;; invalidate-synth! : -> void
|
||||||
|
|
@ -158,8 +156,8 @@
|
||||||
(reductions+ deriv))])
|
(reductions+ deriv))])
|
||||||
(set! raw-steps raw-steps*)
|
(set! raw-steps raw-steps*)
|
||||||
(set! raw-steps-estx estx*)
|
(set! raw-steps-estx estx*)
|
||||||
(set! error error*)
|
(set! raw-steps-exn error*)
|
||||||
(set! definites definites*)))))))
|
(set! raw-steps-definites definites*)))))))
|
||||||
|
|
||||||
;; recache-steps! : -> void
|
;; recache-steps! : -> void
|
||||||
(define/private (recache-steps!)
|
(define/private (recache-steps!)
|
||||||
|
|
@ -271,20 +269,18 @@
|
||||||
|
|
||||||
;; display-initial-term : -> void
|
;; display-initial-term : -> void
|
||||||
(define/public (display-initial-term)
|
(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
|
;; display-final-term : -> void
|
||||||
(define/public (display-final-term)
|
(define/public (display-final-term)
|
||||||
(recache-steps!)
|
(recache-steps!)
|
||||||
(cond [(syntax? raw-steps-estx)
|
(cond [(syntax? raw-steps-estx)
|
||||||
(add-syntax raw-steps-estx binders definites)]
|
(send displayer add-syntax raw-steps-estx
|
||||||
[(exn? error)
|
#:binders binders
|
||||||
(add-error error)]
|
#:definites raw-steps-definites)]
|
||||||
[raw-steps-oops
|
[(exn? raw-steps-exn)
|
||||||
(add-internal-error "steps" raw-steps-oops #f)]
|
(send displayer add-error raw-steps-exn)]
|
||||||
[else
|
[else (display-oops #f)]))
|
||||||
(error 'term-record::display-final-term
|
|
||||||
"internal error")]))
|
|
||||||
|
|
||||||
;; display-step : -> void
|
;; display-step : -> void
|
||||||
(define/public (display-step)
|
(define/public (display-step)
|
||||||
|
|
@ -292,191 +288,23 @@
|
||||||
(cond [steps
|
(cond [steps
|
||||||
(let ([step (cursor:next steps)])
|
(let ([step (cursor:next steps)])
|
||||||
(if step
|
(if step
|
||||||
(add-step step binders)
|
(send displayer add-step step
|
||||||
(add-final raw-steps-estx error binders definites)))]
|
#:binders binders)
|
||||||
[raw-steps-oops
|
(send displayer add-final raw-steps-estx raw-steps-exn
|
||||||
(add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))]
|
#: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
|
[raw-deriv-oops
|
||||||
(add-internal-error "derivation" raw-deriv-oops #f)]
|
(send displayer add-internal-error
|
||||||
|
"derivation" raw-deriv-oops #f events)]
|
||||||
[else
|
[else
|
||||||
(add-internal-error "derivation" #f)]))
|
(error 'term-record::display-oops "internal error")]))
|
||||||
|
|
||||||
(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"))
|
|
||||||
|
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user