Macro Stepper: merged new ui from branches/ryanc/ms-new-ui
svn: r7215 original commit: 2be282a0be517b1a5e8b1156c6dc8bd58e66726b
This commit is contained in:
Ryan Culpepper
parent
0b5b000078
commit
0f119f61a4
|
|
@ -5,11 +5,6 @@
|
|||
(provide expand-only
|
||||
expand/hide)
|
||||
|
||||
(provide expand/step)
|
||||
(define (expand/step . args)
|
||||
(apply (dynamic-require '(lib "stepper.ss" "macro-debugger") 'expand/step)
|
||||
args))
|
||||
|
||||
(define (expand-only stx show-list)
|
||||
(define (show? id)
|
||||
(ormap (lambda (x) (module-identifier=? id x))
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
revappend)
|
||||
(provide walk
|
||||
walk/foci
|
||||
walk/mono
|
||||
stumble
|
||||
stumble/E)
|
||||
|
||||
|
|
@ -213,15 +214,21 @@
|
|||
(current-frontier
|
||||
(apply append (map (make-rename-mapping from to) (current-frontier)))))
|
||||
|
||||
(define (make-rename-mapping from to)
|
||||
(define (make-rename-mapping from0 to0)
|
||||
(define table (make-hash-table))
|
||||
(let loop ([from from] [to to])
|
||||
(let loop ([from from0] [to to0])
|
||||
(cond [(syntax? from)
|
||||
(hash-table-put! table from (flatten-syntaxes to))
|
||||
(loop (syntax-e from) to)]
|
||||
[(syntax? to)
|
||||
(loop from (syntax-e to))]
|
||||
[(pair? from)
|
||||
#;(unless (pair? to)
|
||||
(fprintf (current-error-port)
|
||||
"from:\n~s\n\n" (syntax-object->datum from0))
|
||||
(fprintf (current-error-port)
|
||||
"to:\n~s\n\n" (syntax-object->datum to0))
|
||||
(error 'frontier-renaming))
|
||||
(loop (car from) (car to))
|
||||
(loop (cdr from) (cdr to))]
|
||||
[(vector? from)
|
||||
|
|
@ -264,6 +271,12 @@
|
|||
(current-definites) (current-frontier)
|
||||
(foci foci1) (foci foci2) Ee1 Ee2))
|
||||
|
||||
;; walk/mono : syntax StepType -> Reduction
|
||||
(define (walk/mono e1 type)
|
||||
(make-mono (current-derivation) (big-context) type (context)
|
||||
(current-definites) (current-frontier)
|
||||
(foci e1) e1))
|
||||
|
||||
;; stumble : syntax exception -> Reduction
|
||||
(define (stumble stx exn)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context)
|
||||
|
|
|
|||
|
|
@ -400,7 +400,7 @@
|
|||
[(struct local-lift (expr id))
|
||||
(list (walk expr id 'local-lift))]
|
||||
[(struct local-lift-end (decl))
|
||||
(list (walk decl decl 'module-lift))]
|
||||
(list (walk/mono decl 'module-lift))]
|
||||
[(struct local-bind (deriv))
|
||||
(reductions* deriv)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(module steps mzscheme
|
||||
(require "deriv.ss"
|
||||
"deriv-util.ss")
|
||||
(provide (all-defined))
|
||||
|
||||
;; A ReductionSequence is a (list-of Reduction)
|
||||
|
||||
|
|
@ -22,11 +23,13 @@
|
|||
|
||||
;; A Reduction is one of
|
||||
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
|
||||
;; - (make-mono ... Syntaxes Syntax)
|
||||
;; - (make-misstep ... Syntax Syntax Exception)
|
||||
|
||||
(define-struct protostep (deriv lctx type ctx definites frontier) #f)
|
||||
|
||||
(define-struct (step protostep) (foci1 foci2 e1 e2) #f)
|
||||
(define-struct (mono protostep) (foci1 e1) #f)
|
||||
(define-struct (misstep protostep) (foci1 e1 exn) #f)
|
||||
|
||||
;; context-fill : Context Syntax -> Syntax
|
||||
|
|
@ -56,6 +59,9 @@
|
|||
(define (step-term2 s)
|
||||
(context-fill (protostep-ctx s) (step-e2 s)))
|
||||
|
||||
(define (mono-term1 s)
|
||||
(context-fill (protostep-ctx s) (mono-e1 s)))
|
||||
|
||||
(define (misstep-term1 s)
|
||||
(context-fill (protostep-ctx s) (misstep-e1 s)))
|
||||
|
||||
|
|
@ -106,40 +112,4 @@
|
|||
|
||||
(define (rewrite-step? x)
|
||||
(and (step? x) (not (rename-step? x))))
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
#;(begin
|
||||
(require (lib "contract.ss"))
|
||||
(provide rewrite-step?
|
||||
rename-step?)
|
||||
(provide/contract
|
||||
[step-type->string (any/c . -> . string?)]
|
||||
[step-term1 (step? . -> . syntax?)]
|
||||
[step-term2 (step? . -> . syntax?)]
|
||||
[misstep-term1 (misstep? . -> . syntax?)]
|
||||
[context-fill ((listof procedure?) syntax? . -> . syntax?)]
|
||||
(struct protostep
|
||||
([deriv deriv?]
|
||||
[lctx list?]
|
||||
[type (or/c symbol? boolean?)]
|
||||
[ctx (listof procedure?)]))
|
||||
(struct (step protostep)
|
||||
([deriv deriv?]
|
||||
[lctx list?]
|
||||
[type (or/c symbol? boolean?)]
|
||||
[ctx (listof procedure?)]
|
||||
[foci1 (listof syntax?)]
|
||||
[foci2 (listof syntax?)]
|
||||
[e1 syntax?]
|
||||
[e2 syntax?]))
|
||||
(struct (misstep protostep)
|
||||
([deriv deriv?]
|
||||
[lctx list?]
|
||||
[type (or/c symbol? boolean?)]
|
||||
[ctx (listof procedure?)]
|
||||
[foci1 (listof syntax?)]
|
||||
[e1 syntax?]
|
||||
[exn exn?])))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,5 +5,4 @@
|
|||
|
||||
(define (expand/step stx)
|
||||
(go stx))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
|
||||
(module syntax-browser mzscheme
|
||||
(require "syntax-browser/browser.ss")
|
||||
(require "syntax-browser/frame.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser
|
||||
syntax-snip)
|
||||
make-syntax-browser)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -2,73 +2,75 @@
|
|||
(module controller mzscheme
|
||||
(require (lib "class.ss")
|
||||
"interfaces.ss"
|
||||
"partition.ss")
|
||||
|
||||
(provide syntax-controller%)
|
||||
|
||||
;; syntax-controller%
|
||||
(define syntax-controller%
|
||||
(class* object% (syntax-controller<%>
|
||||
syntax-pp-snip-controller<%>
|
||||
color-controller<%>)
|
||||
(init-field (primary-partition (new-bound-partition)))
|
||||
(init-field (properties-controller #f))
|
||||
"partition.ss"
|
||||
"../util/notify.ss")
|
||||
(provide controller%)
|
||||
|
||||
(define colorers null)
|
||||
(define selection-listeners null)
|
||||
(define selected-syntax #f)
|
||||
(define identifier=?-listeners null)
|
||||
;; displays-manager-mixin
|
||||
(define displays-manager-mixin
|
||||
(mixin () (displays-manager<%>)
|
||||
;; displays : (list-of display<%>)
|
||||
(field [displays null])
|
||||
|
||||
;; syntax-controller<%> Methods
|
||||
;; add-syntax-display : display<%> -> void
|
||||
(define/public (add-syntax-display c)
|
||||
(set! displays (cons c displays)))
|
||||
|
||||
(define/public (select-syntax stx)
|
||||
(set! selected-syntax stx)
|
||||
(send properties-controller set-syntax stx)
|
||||
(for-each (lambda (c) (send c select-syntax stx)) colorers)
|
||||
(for-each (lambda (p) (p stx)) selection-listeners))
|
||||
;; remove-all-syntax-displays : -> void
|
||||
(define/public (remove-all-syntax-displays)
|
||||
(set! displays null))
|
||||
|
||||
(define/public (get-selected-syntax) selected-syntax)
|
||||
(super-new)))
|
||||
|
||||
(define/public (get-properties-controller) properties-controller)
|
||||
(define/public (set-properties-controller pc)
|
||||
(set! properties-controller pc))
|
||||
;; selection-manager-mixin
|
||||
(define selection-manager-mixin
|
||||
(mixin (displays-manager<%>) (selection-manager<%>)
|
||||
(inherit-field displays)
|
||||
(field/notify selected-syntax (new notify-box% (value #f)))
|
||||
|
||||
(define/public (add-view-colorer c)
|
||||
(set! colorers (cons c colorers))
|
||||
(send c select-syntax selected-syntax))
|
||||
|
||||
(define/public (get-view-colorers) colorers)
|
||||
|
||||
(define/public (add-selection-listener p)
|
||||
(set! selection-listeners (cons p selection-listeners)))
|
||||
|
||||
(define/public (on-update-identifier=? name id=?)
|
||||
(set! secondary-partition
|
||||
(and id=? (new partition% (relation id=?))))
|
||||
(for-each (lambda (c) (send c refresh)) colorers)
|
||||
(for-each (lambda (f) (f name id=?)) identifier=?-listeners))
|
||||
|
||||
(define/public (add-identifier=?-listener f)
|
||||
(set! identifier=?-listeners
|
||||
(cons f identifier=?-listeners)))
|
||||
|
||||
(define/public (erase)
|
||||
(set! colorers null))
|
||||
|
||||
;; syntax-pp-snip-controller<%> Methods
|
||||
|
||||
(define/public (on-select-syntax stx)
|
||||
(select-syntax stx))
|
||||
|
||||
;; color-controller<%> Methods
|
||||
|
||||
(define secondary-partition #f)
|
||||
|
||||
(define/public (get-primary-partition) primary-partition)
|
||||
(define/public (get-secondary-partition) secondary-partition)
|
||||
|
||||
;; Initialization
|
||||
(super-new)
|
||||
))
|
||||
|
||||
(listen-selected-syntax
|
||||
(lambda (new-value)
|
||||
(for-each (lambda (display) (send display refresh))
|
||||
displays)))))
|
||||
|
||||
;; mark-manager-mixin
|
||||
(define mark-manager-mixin
|
||||
(mixin () (mark-manager<%>)
|
||||
(init-field [primary-partition (new-bound-partition)])
|
||||
(super-new)
|
||||
|
||||
;; get-primary-partition : -> partition
|
||||
(define/public-final (get-primary-partition)
|
||||
primary-partition)
|
||||
|
||||
;; reset-primary-partition : -> void
|
||||
(define/public-final (reset-primary-partition)
|
||||
(set! primary-partition (new-bound-partition)))))
|
||||
|
||||
;; secondary-partition-mixin
|
||||
(define secondary-partition-mixin
|
||||
(mixin (displays-manager<%>) (secondary-partition<%>)
|
||||
(inherit-field displays)
|
||||
(field/notify identifier=? (new notify-box% (value #f)))
|
||||
(field/notify secondary-partition (new notify-box% (value #f)))
|
||||
|
||||
(listen-identifier=?
|
||||
(lambda (name+proc)
|
||||
(set-secondary-partition
|
||||
(and name+proc
|
||||
(new partition% (relation (cdr name+proc)))))))
|
||||
(listen-secondary-partition
|
||||
(lambda (p)
|
||||
(for-each (lambda (d) (send d refresh))
|
||||
displays)))
|
||||
(super-new)))
|
||||
|
||||
(define controller%
|
||||
(class (secondary-partition-mixin
|
||||
(selection-manager-mixin
|
||||
(mark-manager-mixin
|
||||
(displays-manager-mixin
|
||||
object%))))
|
||||
(super-new)))
|
||||
)
|
||||
|
|
|
|||
251
collects/macro-debugger/syntax-browser/display.ss
Normal file
251
collects/macro-debugger/syntax-browser/display.ss
Normal file
|
|
@ -0,0 +1,251 @@
|
|||
|
||||
(module display mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "plt-match.ss")
|
||||
"params.ss"
|
||||
"pretty-printer.ss"
|
||||
"interfaces.ss"
|
||||
"util.ss")
|
||||
(provide print-syntax-to-editor
|
||||
code-style)
|
||||
|
||||
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
|
||||
(define (print-syntax-to-editor stx text controller)
|
||||
(new display% (syntax stx) (text text) (controller controller)))
|
||||
|
||||
;; FIXME: assumes text never moves
|
||||
|
||||
;; display%
|
||||
(define display%
|
||||
(class* object% (display<%>)
|
||||
(init ((stx syntax)))
|
||||
(init-field text)
|
||||
(init-field controller)
|
||||
|
||||
(define start-anchor (new anchor-snip%))
|
||||
(define end-anchor (new anchor-snip%))
|
||||
(define range #f)
|
||||
(define extra-styles (make-hash-table))
|
||||
|
||||
;; render-syntax : syntax -> void
|
||||
(define/public (render-syntax stx)
|
||||
(with-unlock text
|
||||
(send text delete (get-start-position) (get-end-position))
|
||||
(set! range
|
||||
(print-syntax stx text controller
|
||||
(lambda () (get-start-position))
|
||||
(lambda () (get-end-position))))
|
||||
(apply-primary-partition-styles))
|
||||
(refresh))
|
||||
|
||||
;; refresh : -> void
|
||||
;; Clears all highlighting and reapplies all non-foreground styles.
|
||||
(define/public (refresh)
|
||||
(with-unlock text
|
||||
(send* text
|
||||
(begin-edit-sequence)
|
||||
(change-style unhighlight-d (get-start-position) (get-end-position)))
|
||||
(apply-extra-styles)
|
||||
(let ([selected-syntax (send controller get-selected-syntax)])
|
||||
(apply-secondary-partition-styles selected-syntax)
|
||||
(apply-selection-styles selected-syntax))
|
||||
(send* text
|
||||
(end-edit-sequence))))
|
||||
|
||||
;; cached-start-position : number
|
||||
(define cached-start-position #f)
|
||||
|
||||
;; get-start-position : -> number
|
||||
(define/public-final (get-start-position)
|
||||
(unless cached-start-position
|
||||
(set! cached-start-position (send text get-snip-position start-anchor)))
|
||||
cached-start-position)
|
||||
|
||||
;; get-end-position : -> number
|
||||
(define/public-final (get-end-position)
|
||||
(send text get-snip-position end-anchor))
|
||||
|
||||
;; relative->text-position : number -> number
|
||||
;; FIXME: might be slow to find start every time!
|
||||
(define/public-final (relative->text-position pos)
|
||||
(+ pos (get-start-position)))
|
||||
|
||||
;; Styling
|
||||
|
||||
;; get-range : -> range<%>
|
||||
(define/public (get-range) range)
|
||||
|
||||
;; highlight-syntaxes : (list-of syntax) string -> void
|
||||
(define/public (highlight-syntaxes stxs hi-color)
|
||||
(let ([style-delta (highlight-style-delta hi-color #f)])
|
||||
(for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta))
|
||||
stxs))
|
||||
(refresh))
|
||||
|
||||
;; apply-extra-styles : -> void
|
||||
;; Applies externally-added styles (such as highlighting)
|
||||
(define/private (apply-extra-styles)
|
||||
(hash-table-for-each
|
||||
extra-styles
|
||||
(lambda (hi-stx style-delta)
|
||||
(let ([rs (send range get-ranges hi-stx)])
|
||||
(for-each (lambda (r) (restyle-range r style-delta)) rs)))))
|
||||
|
||||
;; apply-secondary-partition-styles : selected-syntax -> void
|
||||
;; If the selected syntax is an identifier, then styles all identifiers
|
||||
;; in the same partition in blue.
|
||||
(define/private (apply-secondary-partition-styles selected-syntax)
|
||||
(when (identifier? selected-syntax)
|
||||
(let ([partition (send controller get-secondary-partition)])
|
||||
(when partition
|
||||
(for-each (lambda (id)
|
||||
(when (send partition same-partition? selected-syntax id)
|
||||
(draw-secondary-connection id)))
|
||||
(send range get-identifier-list))))))
|
||||
|
||||
;; apply-selection-styles : syntax -> void
|
||||
;; Styles subterms eq to the selected syntax
|
||||
(define/private (apply-selection-styles selected-syntax)
|
||||
(let ([rs (send range get-ranges selected-syntax)])
|
||||
(for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
|
||||
|
||||
;; draw-secondary-connection : syntax -> void
|
||||
(define/private (draw-secondary-connection stx2)
|
||||
(let ([rs (send range get-ranges stx2)])
|
||||
(for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
|
||||
|
||||
;; restyle-range : (cons num num) style-delta% -> void
|
||||
(define/private (restyle-range r style)
|
||||
(send text change-style style
|
||||
(relative->text-position (car r))
|
||||
(relative->text-position (cdr r))))
|
||||
|
||||
;; Primary styles
|
||||
|
||||
;; apply-primary-partition-styles : -> void
|
||||
;; Changes the foreground color according to the primary partition.
|
||||
;; Only called once, when the syntax is first drawn.
|
||||
(define/private (apply-primary-partition-styles)
|
||||
(define (color-style color)
|
||||
(let ([delta (new style-delta%)])
|
||||
(send delta set-delta-foreground color)
|
||||
delta))
|
||||
(define color-styles (list->vector (map color-style (current-colors))))
|
||||
(define overflow-style (color-style "darkgray"))
|
||||
(define color-partition (send controller get-primary-partition))
|
||||
(define offset (get-start-position))
|
||||
(for-each
|
||||
(lambda (range)
|
||||
(let ([stx (range-obj range)]
|
||||
[start (range-start range)]
|
||||
[end (range-end range)])
|
||||
(send text change-style
|
||||
(primary-style stx color-partition color-styles overflow-style)
|
||||
(+ offset start)
|
||||
(+ offset end))))
|
||||
(send range all-ranges)))
|
||||
|
||||
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
|
||||
;; -> style-delta%
|
||||
(define/private (primary-style stx partition color-vector overflow)
|
||||
(let ([n (send partition get-partition stx)])
|
||||
(cond [(< n (vector-length color-vector))
|
||||
(vector-ref color-vector n)]
|
||||
[else
|
||||
overflow])))
|
||||
|
||||
;; Initialize
|
||||
(super-new)
|
||||
(send text insert start-anchor)
|
||||
(send text insert end-anchor)
|
||||
(render-syntax stx)
|
||||
(send controller add-syntax-display this)))
|
||||
|
||||
;; print-syntax : syntax controller (-> number) (-> number)
|
||||
;; -> range%
|
||||
(define (print-syntax stx text controller
|
||||
get-start-position get-end-position)
|
||||
(define primary-partition (send controller get-primary-partition))
|
||||
(define real-output-port (make-text-port text get-end-position))
|
||||
(define output-port (open-output-string))
|
||||
|
||||
(port-count-lines! output-port)
|
||||
(let ([range (pretty-print-syntax stx output-port primary-partition)])
|
||||
(write-string (get-output-string output-port) real-output-port)
|
||||
(let ([end (get-end-position)])
|
||||
;; Pretty printer always inserts final newline; we remove it here.
|
||||
(send text delete (sub1 end) end))
|
||||
;; Set font to standard
|
||||
(send text change-style
|
||||
(code-style text)
|
||||
(get-start-position)
|
||||
(get-end-position))
|
||||
(let ([offset (get-start-position)])
|
||||
(fixup-parentheses text range offset)
|
||||
(for-each
|
||||
(lambda (range)
|
||||
(let* ([stx (range-obj range)]
|
||||
[start (range-start range)]
|
||||
[end (range-end range)])
|
||||
(send text set-clickback (+ offset start) (+ offset end)
|
||||
(lambda (_1 _2 _3)
|
||||
(send controller set-selected-syntax stx)))))
|
||||
(send range all-ranges))
|
||||
range)))
|
||||
|
||||
;; fixup-parentheses : text range -> void
|
||||
(define (fixup-parentheses text range offset)
|
||||
(define (fixup r)
|
||||
(let ([stx (range-obj r)]
|
||||
[start (+ offset (range-start r))]
|
||||
[end (+ offset (range-end r))])
|
||||
(when (and (syntax? stx) (pair? (syntax-e stx)))
|
||||
(case (syntax-property stx 'paren-shape)
|
||||
((#\[)
|
||||
(replace start #\[)
|
||||
(replace (sub1 end) #\]))
|
||||
((#\{)
|
||||
(replace start #\{)
|
||||
(replace (sub1 end) #\}))))))
|
||||
(define (replace pos char)
|
||||
(send text insert char pos (add1 pos)))
|
||||
(for-each fixup (send range all-ranges)))
|
||||
|
||||
;; code-style : text<%> -> style<%>
|
||||
(define (code-style text)
|
||||
(let* ([style-list (send text get-style-list)]
|
||||
[style (send style-list find-named-style "Standard")]
|
||||
[font-size (current-syntax-font-size)])
|
||||
(if font-size
|
||||
(send style-list find-or-create-style
|
||||
style
|
||||
(make-object style-delta% 'change-size font-size))
|
||||
style)))
|
||||
|
||||
;; anchor-snip%
|
||||
(define anchor-snip%
|
||||
(class snip%
|
||||
(define/override (copy)
|
||||
(make-object string-snip% ""))
|
||||
(super-instantiate ())))
|
||||
|
||||
;; Styles
|
||||
|
||||
(define (highlight-style-delta color em?)
|
||||
(let ([sd (new style-delta%)])
|
||||
(unless em? (send sd set-delta-background color))
|
||||
(when em? (send sd set-weight-on 'bold))
|
||||
(unless em? (send sd set-underlined-off #t)
|
||||
(send sd set-weight-off 'bold))
|
||||
sd))
|
||||
|
||||
(define selection-color "yellow")
|
||||
(define subselection-color "yellow")
|
||||
|
||||
(define select-highlight-d (highlight-style-delta selection-color #t))
|
||||
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
|
||||
|
||||
(define unhighlight-d (highlight-style-delta "white" #f))
|
||||
|
||||
)
|
||||
|
|
@ -3,13 +3,11 @@
|
|||
(require "interfaces.ss"
|
||||
"widget.ss"
|
||||
"keymap.ss"
|
||||
"implementation.ss"
|
||||
"params.ss"
|
||||
"partition.ss")
|
||||
|
||||
(provide (all-from "interfaces.ss")
|
||||
(all-from "widget.ss")
|
||||
(all-from "keymap.ss")
|
||||
(all-from "implementation.ss")
|
||||
(all-from "params.ss")
|
||||
identifier=-choices))
|
||||
|
|
|
|||
|
|
@ -1,97 +1,96 @@
|
|||
|
||||
(module frame mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "list.ss")
|
||||
"interfaces.ss"
|
||||
"partition.ss")
|
||||
(provide frame@)
|
||||
|
||||
(define frame@
|
||||
(unit
|
||||
(import prefs^
|
||||
widget^)
|
||||
(export browser^)
|
||||
"partition.ss"
|
||||
"prefs.ss"
|
||||
"widget.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser
|
||||
syntax-browser-frame%
|
||||
syntax-widget/controls%)
|
||||
|
||||
;; browse-syntax : syntax -> void
|
||||
(define (browse-syntax stx)
|
||||
(browse-syntaxes (list stx)))
|
||||
|
||||
;; browse-syntaxes : (list-of syntax) -> void
|
||||
(define (browse-syntaxes stxs)
|
||||
(let ((w (make-syntax-browser)))
|
||||
(for-each (lambda (stx)
|
||||
(send w add-syntax stx)
|
||||
(send w add-separator))
|
||||
stxs)))
|
||||
|
||||
;; make-syntax-browser : -> syntax-browser<%>
|
||||
(define (make-syntax-browser)
|
||||
(let* ([view (new syntax-browser-frame%)])
|
||||
(send view show #t)
|
||||
(send view get-widget)))
|
||||
|
||||
;; syntax-browser-frame%
|
||||
(define syntax-browser-frame%
|
||||
(class* frame% ()
|
||||
(super-new (label "Syntax Browser")
|
||||
(width (pref:width))
|
||||
(height (pref:height)))
|
||||
(define widget
|
||||
(new syntax-widget/controls%
|
||||
(parent this)
|
||||
(pref:props-percentage pref:props-percentage)))
|
||||
(define/public (get-widget) widget)
|
||||
(define/augment (on-close)
|
||||
(pref:width (send this get-width))
|
||||
(pref:height (send this get-height))
|
||||
(send widget save-prefs)
|
||||
(inner (void) on-close))
|
||||
))
|
||||
|
||||
;; syntax-widget/controls%
|
||||
(define syntax-widget/controls%
|
||||
(class* syntax-widget% ()
|
||||
(inherit get-main-panel
|
||||
get-controller
|
||||
toggle-props)
|
||||
(super-new)
|
||||
|
||||
(define -control-panel
|
||||
(new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
|
||||
|
||||
;; Put the control panel up front
|
||||
(send (get-main-panel) change-children
|
||||
(lambda (children)
|
||||
(cons -control-panel (remq -control-panel children))))
|
||||
|
||||
(define -identifier=-choices (identifier=-choices))
|
||||
(define -choice
|
||||
(new choice% (label "identifer=?") (parent -control-panel)
|
||||
(choices (map car -identifier=-choices))
|
||||
(callback (lambda _ (on-update-identifier=?-choice)))))
|
||||
(new button%
|
||||
(label "Clear")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (send (get-controller) select-syntax #f))))
|
||||
(new button%
|
||||
(label "Properties")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (toggle-props))))
|
||||
|
||||
(define/private (on-update-identifier=?-choice)
|
||||
(cond [(assoc (send -choice get-string-selection)
|
||||
-identifier=-choices)
|
||||
=> (lambda (p)
|
||||
(send (get-controller)
|
||||
on-update-identifier=? (car p) (cdr p)))]
|
||||
[else #f]))
|
||||
(send (get-controller) add-identifier=?-listener
|
||||
(lambda (name func)
|
||||
(send -choice set-selection
|
||||
(or (send -choice find-string name) 0))))))
|
||||
|
||||
;; browse-syntax : syntax -> void
|
||||
(define (browse-syntax stx)
|
||||
(browse-syntaxes (list stx)))
|
||||
|
||||
;; browse-syntaxes : (list-of syntax) -> void
|
||||
(define (browse-syntaxes stxs)
|
||||
(let ((w (make-syntax-browser)))
|
||||
(for-each (lambda (stx)
|
||||
(send w add-syntax stx)
|
||||
(send w add-separator))
|
||||
stxs)))
|
||||
|
||||
;; make-syntax-browser : -> syntax-browser<%>
|
||||
(define (make-syntax-browser)
|
||||
(let* ([view (new syntax-browser-frame%)])
|
||||
(send view show #t)
|
||||
(send view get-widget)))
|
||||
|
||||
;; syntax-browser-frame%
|
||||
(define syntax-browser-frame%
|
||||
(class* frame% ()
|
||||
(init-field [config (new syntax-prefs%)])
|
||||
(super-new (label "Syntax Browser")
|
||||
(width (send config pref:width))
|
||||
(height (send config pref:height)))
|
||||
(define widget
|
||||
(new syntax-widget/controls%
|
||||
(parent this)
|
||||
(config config)))
|
||||
(define/public (get-widget) widget)
|
||||
(define/augment (on-close)
|
||||
(send config pref:width (send this get-width))
|
||||
(send config pref:height (send this get-height))
|
||||
(send widget shutdown)
|
||||
(inner (void) on-close))
|
||||
))
|
||||
|
||||
;; syntax-widget/controls%
|
||||
(define syntax-widget/controls%
|
||||
(class* widget% ()
|
||||
(inherit get-main-panel
|
||||
get-controller
|
||||
toggle-props)
|
||||
(super-new)
|
||||
(inherit-field config)
|
||||
|
||||
(define -control-panel
|
||||
(new horizontal-pane%
|
||||
(parent (get-main-panel))
|
||||
(stretchable-height #f)))
|
||||
|
||||
;; Put the control panel up front
|
||||
(send (get-main-panel) change-children
|
||||
(lambda (children)
|
||||
(cons -control-panel (remq -control-panel children))))
|
||||
|
||||
(define -identifier=-choices (identifier=-choices))
|
||||
(define -choice
|
||||
(new choice% (label "identifer=?") (parent -control-panel)
|
||||
(choices (map car -identifier=-choices))
|
||||
(callback
|
||||
(lambda (c e)
|
||||
(send (get-controller) set-identifier=?
|
||||
(assoc (send c get-string-selection)
|
||||
-identifier=-choices))))))
|
||||
(new button%
|
||||
(label "Clear")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (send (get-controller) select-syntax #f))))
|
||||
(new button%
|
||||
(label "Properties")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (toggle-props))))
|
||||
|
||||
(send (get-controller) listen-identifier=?
|
||||
(lambda (name+func)
|
||||
(send -choice set-selection
|
||||
(or (send -choice find-string (car name+func)) 0))))
|
||||
))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,130 +1,150 @@
|
|||
|
||||
(module interfaces mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss"))
|
||||
(require (lib "class.ss"))
|
||||
(provide (all-defined))
|
||||
|
||||
;; Signatures
|
||||
|
||||
(define-signature browser^
|
||||
(;; browse-syntax : syntax -> void
|
||||
browse-syntax
|
||||
|
||||
;; browse-syntaxes : (list-of syntax) -> void
|
||||
browse-syntaxes
|
||||
|
||||
;; make-syntax-browser : -> syntax-browser<%>
|
||||
make-syntax-browser
|
||||
|
||||
;; syntax-widget/controls%
|
||||
syntax-widget/controls%
|
||||
|
||||
;; syntax-browser-frame%
|
||||
syntax-browser-frame%))
|
||||
|
||||
(define-signature prefs^
|
||||
(;; pref:width : pref of number
|
||||
pref:width
|
||||
|
||||
;; pref:height : pref of number
|
||||
pref:height
|
||||
|
||||
;; pref:props-percentage : pref of number in (0,1)
|
||||
pref:props-percentage))
|
||||
|
||||
(define-signature keymap^
|
||||
(;; syntax-keymap% implements syntax-keymap<%>
|
||||
syntax-keymap%))
|
||||
|
||||
(define-signature context-menu^
|
||||
(;; context-menu%
|
||||
context-menu%))
|
||||
|
||||
(define-signature snip^
|
||||
(;; syntax-snip : syntax -> snip
|
||||
syntax-snip
|
||||
|
||||
;; syntax-snip%
|
||||
syntax-snip%))
|
||||
|
||||
(define-signature snipclass^
|
||||
(;; snip-class
|
||||
snip-class))
|
||||
|
||||
(define-signature widget^
|
||||
(;; syntax-widget%
|
||||
syntax-widget%))
|
||||
|
||||
;; Class Interfaces
|
||||
|
||||
;; syntax-controller<%>
|
||||
;; A syntax-controller coordinates state shared by many different syntax views.
|
||||
;; Syntax views can share:
|
||||
;; - selection
|
||||
;; - partitioning configuration
|
||||
;; - property display
|
||||
(define syntax-controller<%>
|
||||
;; displays-manager<%>
|
||||
(define displays-manager<%>
|
||||
(interface ()
|
||||
;; select-syntax : syntax -> void
|
||||
select-syntax
|
||||
|
||||
;; get-selected-syntax : -> syntax/#f
|
||||
;; add-syntax-display : display<%> -> void
|
||||
add-syntax-display
|
||||
|
||||
;; remove-all-syntax-displays : -> void
|
||||
remove-all-syntax-displays))
|
||||
|
||||
;; selection-manager<%>
|
||||
(define selection-manager<%>
|
||||
(interface ()
|
||||
;; set-selected-syntax : syntax -> void
|
||||
set-selected-syntax
|
||||
|
||||
;; get-selected-syntax : -> syntax
|
||||
get-selected-syntax
|
||||
|
||||
;; get-properties-controller : -> syntax-properties-controller<%>
|
||||
get-properties-controller
|
||||
|
||||
;; add-view-colorer : syntax-colorer<%> -> void
|
||||
add-view-colorer
|
||||
|
||||
;; get-view-colorers : -> (list-of syntax-colorer<%>)
|
||||
get-view-colorers
|
||||
|
||||
;; add-selection-listener : syntax -> void
|
||||
add-selection-listener
|
||||
))
|
||||
|
||||
;; syntax-properties-controller<%>
|
||||
(define syntax-properties-controller<%>
|
||||
(interface ()
|
||||
;; set-syntax : syntax -> void
|
||||
set-syntax
|
||||
|
||||
;; show : boolean -> void
|
||||
#;show
|
||||
|
||||
;; props-shown? : -> boolean
|
||||
props-shown?))
|
||||
;; listen-selected-syntax : (syntax -> void) -> void
|
||||
listen-selected-syntax))
|
||||
|
||||
;; syntax-configuration<%>
|
||||
(define syntax-configuration<%>
|
||||
;; mark-manager<%>
|
||||
;; Manages marks, mappings from marks to colors
|
||||
(define mark-manager<%>
|
||||
(interface ()
|
||||
;; get-primary-partition : -> partition<%>
|
||||
get-primary-partition
|
||||
|
||||
;; get-primary-partition : -> partition
|
||||
get-primary-partition))
|
||||
|
||||
;; secondary-partition<%>
|
||||
(define secondary-partition<%>
|
||||
(interface (displays-manager<%>)
|
||||
;; get-secondary-partition : -> partition<%>
|
||||
get-secondary-partition
|
||||
|
||||
;; update-identifier=? : ... -> void
|
||||
update-identifier=?))
|
||||
|
||||
|
||||
;; syntax-colorer<%>
|
||||
(define syntax-colorer<%>
|
||||
(interface ()
|
||||
select-syntax
|
||||
apply-styles))
|
||||
;; set-secondary-partition : partition<%> -> void
|
||||
set-secondary-partition
|
||||
|
||||
;; syntax-sharing-context<%>
|
||||
;; A syntax-sharing-context<%>
|
||||
;; Syntax snips search their enclosing editors for instances of sharing contexts
|
||||
(define syntax-sharing-context<%>
|
||||
;; listen-secondary-partition : (partition<%> -> void) -> void
|
||||
listen-secondary-partition
|
||||
|
||||
;; get-identifier=? : -> (cons string procedure)
|
||||
get-identifier=?
|
||||
|
||||
;; set-identifier=? : (cons string procedure) -> void
|
||||
set-identifier=?
|
||||
|
||||
;; listen-identifier=? : ((cons string procedure) -> void) -> void
|
||||
listen-identifier=?))
|
||||
|
||||
;; controller<%>
|
||||
(define controller<%>
|
||||
(interface (displays-manager<%>
|
||||
selection-manager<%>
|
||||
mark-manager<%>
|
||||
secondary-partition<%>)))
|
||||
|
||||
;; host<%>
|
||||
(define host<%>
|
||||
(interface ()
|
||||
;; get-shared-partition
|
||||
get-shared-partition))
|
||||
;; get-controller : -> controller<%>
|
||||
get-controller
|
||||
|
||||
;; add-keymap : text snip
|
||||
add-keymap
|
||||
))
|
||||
|
||||
|
||||
;; display<%>
|
||||
(define display<%>
|
||||
(interface ()
|
||||
;; refresh : -> void
|
||||
refresh
|
||||
|
||||
;; highlight-syntaxes : (list-of syntax) color -> void
|
||||
highlight-syntaxes
|
||||
|
||||
;; get-start-position : -> number
|
||||
get-start-position
|
||||
|
||||
;; get-end-position : -> number
|
||||
get-end-position
|
||||
|
||||
;; get-range : -> range<%>
|
||||
get-range))
|
||||
|
||||
;; range<%>
|
||||
(define range<%>
|
||||
(interface ()
|
||||
;; get-ranges : datum -> (list-of (cons number number))
|
||||
get-ranges
|
||||
|
||||
;; all-ranges : (list-of Range)
|
||||
;; Sorted outermost-first
|
||||
all-ranges
|
||||
|
||||
;; get-identifier-list : (list-of identifier)
|
||||
get-identifier-list))
|
||||
|
||||
;; A Range is (make-range datum number number)
|
||||
(define-struct range (obj start end))
|
||||
|
||||
|
||||
;; syntax-prefs<%>
|
||||
(define syntax-prefs<%>
|
||||
(interface ()
|
||||
pref:width
|
||||
pref:height
|
||||
pref:props-percentage
|
||||
pref:props-shown?))
|
||||
|
||||
;; widget-hooks<%>
|
||||
(define widget-hooks<%>
|
||||
(interface ()
|
||||
;; setup-keymap : -> void
|
||||
setup-keymap
|
||||
|
||||
;; shutdown : -> void
|
||||
shutdown
|
||||
))
|
||||
|
||||
;; keymap-hooks<%>
|
||||
(define keymap-hooks<%>
|
||||
(interface ()
|
||||
;; make-context-menu : -> context-menu<%>
|
||||
make-context-menu
|
||||
|
||||
;; get-context-menu% : -> class
|
||||
get-context-menu%))
|
||||
|
||||
;; context-menu-hooks<%>
|
||||
(define context-menu-hooks<%>
|
||||
(interface ()
|
||||
add-edit-items
|
||||
after-edit-items
|
||||
add-selection-items
|
||||
after-selection-items
|
||||
add-partition-items
|
||||
after-partition-items))
|
||||
|
||||
|
||||
;;----------
|
||||
|
||||
|
||||
;; Convenience widget, specialized for displaying stx and not much else
|
||||
(define syntax-browser<%>
|
||||
(interface ()
|
||||
|
|
@ -135,51 +155,16 @@
|
|||
select-syntax
|
||||
get-text
|
||||
))
|
||||
|
||||
|
||||
(define partition<%>
|
||||
(interface ()
|
||||
;; get-partition : any -> number
|
||||
get-partition
|
||||
|
||||
|
||||
;; same-partition? : any any -> number
|
||||
same-partition?
|
||||
|
||||
|
||||
;; count : -> number
|
||||
count))
|
||||
|
||||
;; Internal interfaces
|
||||
|
||||
(define syntax-pp-snip-controller<%>
|
||||
(interface ()
|
||||
on-select-syntax
|
||||
))
|
||||
|
||||
(define color-controller<%>
|
||||
(interface ()
|
||||
get-primary-partition
|
||||
get-secondary-partition
|
||||
))
|
||||
|
||||
(define syntax-pp<%>
|
||||
(interface ()
|
||||
pretty-print-syntax
|
||||
|
||||
get-range
|
||||
get-identifier-list
|
||||
flat=>stx
|
||||
stx=>flat))
|
||||
|
||||
(define typesetter<%>
|
||||
(interface ()
|
||||
get-output-port
|
||||
get-current-position))
|
||||
|
||||
(define range<%>
|
||||
(interface ()
|
||||
get-start
|
||||
set-start
|
||||
get-ranges
|
||||
add-range
|
||||
all-ranges))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,177 +1,152 @@
|
|||
|
||||
(module keymap mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
"interfaces.ss"
|
||||
"partition.ss")
|
||||
(provide keymap@
|
||||
context-menu@)
|
||||
|
||||
(define context-menu@
|
||||
(unit
|
||||
(import)
|
||||
(export context-menu^)
|
||||
(provide syntax-keymap%
|
||||
context-menu%)
|
||||
|
||||
(define context-menu%
|
||||
(class popup-menu%
|
||||
(init-field keymap)
|
||||
(init-field controller)
|
||||
(super-new)
|
||||
|
||||
(field [copy-menu #f]
|
||||
[copy-syntax-menu #f]
|
||||
[clear-menu #f]
|
||||
[props-menu #f])
|
||||
|
||||
(define/public (add-edit-items)
|
||||
(set! copy-menu
|
||||
(new menu-item% (label "Copy") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "copy-text" i e)))))
|
||||
(set! copy-syntax-menu
|
||||
(new menu-item% (label "Copy syntax") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "copy-syntax" i e)))))
|
||||
(void))
|
||||
(define syntax-keymap%
|
||||
(class keymap%
|
||||
(init editor)
|
||||
(init-field controller)
|
||||
|
||||
(define/public (after-edit-items)
|
||||
(void))
|
||||
(inherit add-function
|
||||
map-function
|
||||
chain-to-keymap)
|
||||
(super-new)
|
||||
|
||||
(define/public (add-selection-items)
|
||||
(set! clear-menu
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "clear-syntax-selection" i e)))))
|
||||
(set! props-menu
|
||||
(new menu-item%
|
||||
(label "Show syntax properties")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "show-syntax-properties" i e)))))
|
||||
(void))
|
||||
|
||||
(define/public (after-selection-items)
|
||||
(void))
|
||||
(define/public (get-context-menu%)
|
||||
context-menu%)
|
||||
|
||||
(define/public (add-partition-items)
|
||||
(let ([secondary (new menu% (label "identifier=?") (parent this))])
|
||||
(for-each
|
||||
(lambda (name func)
|
||||
(let ([this-choice
|
||||
(new checkable-menu-item%
|
||||
(label name)
|
||||
(parent secondary)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send controller on-update-identifier=? name func))))])
|
||||
(send controller add-identifier=?-listener
|
||||
(lambda (new-name new-id=?)
|
||||
(send this-choice check (eq? name new-name))))))
|
||||
(map car (identifier=-choices))
|
||||
(map cdr (identifier=-choices))))
|
||||
(void))
|
||||
|
||||
(define/public (after-partition-items)
|
||||
(void))
|
||||
(define/public (make-context-menu)
|
||||
(new (get-context-menu%) (controller controller) (keymap this)))
|
||||
|
||||
(define/public (add-separator)
|
||||
(new separator-menu-item% (parent this)))
|
||||
|
||||
(define/override (on-demand)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send copy-menu enable (and stx #t))
|
||||
(send copy-syntax-menu enable (and stx #t))
|
||||
(send clear-menu enable (and stx #t))
|
||||
(super on-demand))
|
||||
;; Key mappings
|
||||
|
||||
;; Initialization
|
||||
(add-edit-items)
|
||||
(after-edit-items)
|
||||
(map-function "rightbutton" "popup-context-window")
|
||||
|
||||
(add-separator)
|
||||
(add-selection-items)
|
||||
(after-selection-items)
|
||||
;; Functionality
|
||||
|
||||
(add-separator)
|
||||
(add-partition-items)
|
||||
(after-partition-items)
|
||||
(add-function "popup-context-window"
|
||||
(lambda (editor event)
|
||||
(do-popup-context-window editor event)))
|
||||
|
||||
))))
|
||||
|
||||
(define keymap@
|
||||
(unit
|
||||
(import context-menu^ snip^)
|
||||
(export keymap^)
|
||||
|
||||
(define syntax-keymap%
|
||||
(class keymap%
|
||||
(init editor)
|
||||
(init-field controller)
|
||||
|
||||
(inherit add-function
|
||||
map-function
|
||||
chain-to-keymap)
|
||||
(super-new)
|
||||
|
||||
(define context-menu (make-context-menu))
|
||||
|
||||
(define/public (make-context-menu)
|
||||
(new context-menu% (controller controller) (keymap this)))
|
||||
|
||||
;; Key mappings
|
||||
(add-function "copy-text"
|
||||
(lambda (_ event)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send the-clipboard set-clipboard-string
|
||||
(if stx
|
||||
(format "~s" (syntax-object->datum stx))
|
||||
"")
|
||||
(send event get-time-stamp))))
|
||||
|
||||
(map-function "rightbutton" "popup-context-window")
|
||||
|
||||
;; Functionality
|
||||
|
||||
(add-function "popup-context-window"
|
||||
(lambda (editor event)
|
||||
(do-popup-context-window editor event)))
|
||||
|
||||
(add-function "copy-text"
|
||||
(lambda (_ event)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send the-clipboard set-clipboard-string
|
||||
(if stx
|
||||
(format "~s" (syntax-object->datum stx))
|
||||
"")
|
||||
(send event get-time-stamp))))
|
||||
|
||||
(add-function "copy-syntax"
|
||||
(lambda (_ event)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(define t (new text%))
|
||||
(send t insert
|
||||
(new syntax-snip%
|
||||
(syntax stx)))
|
||||
(send t select-all)
|
||||
(send t copy)))
|
||||
|
||||
(add-function "clear-syntax-selection"
|
||||
(lambda (i e)
|
||||
(send controller select-syntax #f)))
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(error 'show-syntax-properties "not provided by this keymap")))
|
||||
|
||||
;; Attach to editor
|
||||
(add-function "clear-syntax-selection"
|
||||
(lambda (i e)
|
||||
(send controller set-selected-syntax #f)))
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(error 'show-syntax-properties "not provided by this keymap")))
|
||||
|
||||
;; Attach to editor
|
||||
|
||||
(chain-to-keymap (send editor get-keymap) #t)
|
||||
(send editor set-keymap this)
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
(define/private (do-popup-context-window editor event)
|
||||
(define-values (x y)
|
||||
(send editor dc-location-to-editor-location
|
||||
(send event get-x)
|
||||
(send event get-y)))
|
||||
(define admin (send editor get-admin))
|
||||
(send admin popup-menu (make-context-menu) x y))))
|
||||
|
||||
(define context-menu%
|
||||
(class popup-menu%
|
||||
(init-field keymap)
|
||||
(init-field controller)
|
||||
(super-new)
|
||||
|
||||
(field [copy-menu #f]
|
||||
[clear-menu #f]
|
||||
[props-menu #f])
|
||||
|
||||
(define/public (add-edit-items)
|
||||
(set! copy-menu
|
||||
(new menu-item% (label "Copy") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "copy-text" i e)))))
|
||||
(void))
|
||||
|
||||
(define/public (after-edit-items)
|
||||
(void))
|
||||
|
||||
(define/public (add-selection-items)
|
||||
(set! clear-menu
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "clear-syntax-selection" i e)))))
|
||||
(set! props-menu
|
||||
(new menu-item%
|
||||
(label "Show syntax properties")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "show-syntax-properties" i e)))))
|
||||
(void))
|
||||
|
||||
(define/public (after-selection-items)
|
||||
(void))
|
||||
|
||||
(define/public (add-partition-items)
|
||||
(let ([secondary (new menu% (label "identifier=?") (parent this))])
|
||||
(for-each
|
||||
(lambda (name func)
|
||||
(let ([this-choice
|
||||
(new checkable-menu-item%
|
||||
(label name)
|
||||
(parent secondary)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send controller set-identifier=?
|
||||
(cons name func)))))])
|
||||
(send controller listen-identifier=?
|
||||
(lambda (name+proc)
|
||||
(send this-choice check (eq? name (car name+proc)))))))
|
||||
(map car (identifier=-choices))
|
||||
(map cdr (identifier=-choices))))
|
||||
(void))
|
||||
|
||||
(define/public (after-partition-items)
|
||||
(void))
|
||||
|
||||
(define/public (add-separator)
|
||||
(new separator-menu-item% (parent this)))
|
||||
|
||||
(define/override (on-demand)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send copy-menu enable (and stx #t))
|
||||
(send clear-menu enable (and stx #t))
|
||||
(super on-demand))
|
||||
|
||||
;; Initialization
|
||||
(add-edit-items)
|
||||
(after-edit-items)
|
||||
|
||||
(add-separator)
|
||||
(add-selection-items)
|
||||
(after-selection-items)
|
||||
|
||||
(add-separator)
|
||||
(add-partition-items)
|
||||
(after-partition-items)
|
||||
))
|
||||
|
||||
(chain-to-keymap (send editor get-keymap) #t)
|
||||
(send editor set-keymap this)
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
(define/private (do-popup-context-window editor event)
|
||||
(define-values (x y)
|
||||
(send editor dc-location-to-editor-location
|
||||
(send event get-x)
|
||||
(send event get-y)))
|
||||
(define admin (send editor get-admin))
|
||||
(send admin popup-menu context-menu x y))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,31 +1,32 @@
|
|||
|
||||
(module prefs mzscheme
|
||||
(require (lib "unit.ss")
|
||||
(require (lib "class.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"interfaces.ss")
|
||||
(provide prefs@)
|
||||
|
||||
(define-syntax pref:get/set
|
||||
(syntax-rules ()
|
||||
[(_ get/set prop)
|
||||
(define get/set
|
||||
(case-lambda
|
||||
[() (preferences:get 'prop)]
|
||||
[(newval) (preferences:set 'prop newval)]))]))
|
||||
"interfaces.ss"
|
||||
"../util/misc.ss")
|
||||
(provide syntax-prefs%
|
||||
syntax-prefs-mixin
|
||||
|
||||
(define prefs@
|
||||
(unit
|
||||
(import)
|
||||
(export prefs^)
|
||||
|
||||
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
|
||||
|
||||
(pref:get/set pref:width SyntaxBrowser:Width)
|
||||
(pref:get/set pref:height SyntaxBrowser:Height)
|
||||
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
|
||||
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)))
|
||||
|
||||
pref:tabify)
|
||||
|
||||
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
|
||||
|
||||
(pref:get/set pref:width SyntaxBrowser:Width)
|
||||
(pref:get/set pref:height SyntaxBrowser:Height)
|
||||
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
|
||||
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
|
||||
|
||||
(pref:get/set pref:tabify framework:tabify)
|
||||
|
||||
(define syntax-prefs-mixin
|
||||
(closure-mixin (syntax-prefs<%>)
|
||||
(pref:width pref:width)
|
||||
(pref:height pref:height)
|
||||
(pref:props-percentage pref:props-percentage)
|
||||
(pref:props-shown? pref:props-shown?)))
|
||||
|
||||
(define syntax-prefs% (syntax-prefs-mixin object%))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
|
||||
(module pretty-helper mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
|
|
|
|||
|
|
@ -6,108 +6,156 @@
|
|||
(lib "class.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
"pretty-range.ss"
|
||||
"pretty-helper.ss"
|
||||
"interfaces.ss"
|
||||
"params.ss")
|
||||
(provide syntax-pp%
|
||||
(struct range (obj start end)))
|
||||
"params.ss"
|
||||
"prefs.ss")
|
||||
|
||||
;; syntax-pp%
|
||||
;; Pretty printer for syntax objects.
|
||||
(define syntax-pp%
|
||||
(class* object% (syntax-pp<%>)
|
||||
(init-field main-stx)
|
||||
(init-field typesetter)
|
||||
(init-field (primary-partition #f))
|
||||
(init-field (columns (current-default-columns)))
|
||||
(provide pretty-print-syntax)
|
||||
|
||||
(unless (syntax? main-stx)
|
||||
(error 'syntax-pretty-printer "got non-syntax object: ~s" main-stx))
|
||||
;; pretty-print-syntax : syntax port partition -> range%
|
||||
(define (pretty-print-syntax stx port primary-partition)
|
||||
(define range-builder (new range-builder%))
|
||||
(define-values (datum ht:flat=>stx ht:stx=>flat)
|
||||
(syntax->datum/tables stx primary-partition
|
||||
(length (current-colors))
|
||||
(current-suffix-option)))
|
||||
(define identifier-list
|
||||
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))
|
||||
(define (flat=>stx obj)
|
||||
(hash-table-get ht:flat=>stx obj))
|
||||
(define (stx=>flat stx)
|
||||
(hash-table-get ht:stx=>flat stx))
|
||||
(define (current-position)
|
||||
(let-values ([(line column position) (port-next-location port)])
|
||||
(sub1 position)))
|
||||
(define (pp-pre-hook obj port)
|
||||
(send range-builder set-start obj (current-position)))
|
||||
(define (pp-post-hook obj port)
|
||||
(let ([start (send range-builder get-start obj)]
|
||||
[end (current-position)]
|
||||
[stx (flat=>stx obj)])
|
||||
(when (and start stx)
|
||||
(send range-builder add-range stx (cons start end)))))
|
||||
(define (pp-extend-style-table identifier-list)
|
||||
(let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)]
|
||||
[like-syms (map syntax-e identifier-list)])
|
||||
(pretty-print-extend-style-table (pp-better-style-table)
|
||||
syms
|
||||
like-syms)))
|
||||
|
||||
(define datum #f)
|
||||
(define ht:flat=>stx #f)
|
||||
(define ht:stx=>flat #f)
|
||||
(define identifier-list null)
|
||||
(define -range #f)
|
||||
|
||||
(define/public (get-range) -range)
|
||||
(define/public (get-identifier-list) identifier-list)
|
||||
(define/public (flat=>stx obj)
|
||||
(hash-table-get ht:flat=>stx obj))
|
||||
(define/public (stx=>flat obj)
|
||||
(hash-table-get ht:stx=>flat obj))
|
||||
|
||||
(define/public (pretty-print-syntax)
|
||||
(define range (new ranges%))
|
||||
(define (pp-pre-hook obj port)
|
||||
(send range set-start obj (send typesetter get-current-position)))
|
||||
(define (pp-post-hook obj port)
|
||||
(let ([start (send range get-start obj)]
|
||||
[end (send typesetter get-current-position)])
|
||||
(when start
|
||||
(send range add-range
|
||||
(flat=>stx obj)
|
||||
(cons start end)))))
|
||||
(define (pp-size-hook obj display-like? port)
|
||||
(cond [(is-a? obj editor-snip%)
|
||||
columns]
|
||||
[(syntax-dummy? obj)
|
||||
(let ((ostring (open-output-string)))
|
||||
((if display-like? display write) (syntax-dummy-val obj) ostring)
|
||||
(string-length (get-output-string ostring)))]
|
||||
[else #f]))
|
||||
(define (pp-print-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
((if display-like? display write) (syntax-dummy-val obj) port)]
|
||||
[(is-a? obj editor-snip%)
|
||||
(write-special obj port)]
|
||||
[else
|
||||
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
||||
(define (pp-extend-style-table)
|
||||
(let* ([ids identifier-list]
|
||||
[syms (map (lambda (x) (stx=>flat x)) ids)]
|
||||
[like-syms (map syntax-e ids)])
|
||||
(pretty-print-extend-style-table (pp-better-style-table)
|
||||
syms
|
||||
like-syms)))
|
||||
(define (pp-better-style-table)
|
||||
(pretty-print-extend-style-table (pretty-print-current-style-table)
|
||||
(map car extended-style-list)
|
||||
(map cdr extended-style-list)))
|
||||
|
||||
(parameterize
|
||||
([pretty-print-pre-print-hook pp-pre-hook]
|
||||
[pretty-print-post-print-hook pp-post-hook]
|
||||
[pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-columns columns]
|
||||
[pretty-print-current-style-table (pp-extend-style-table)]
|
||||
;; Printing parameters (mzscheme manual 7.9.1.4)
|
||||
[print-unreadable #t]
|
||||
[print-graph #f]
|
||||
[print-struct #f]
|
||||
[print-box #t]
|
||||
[print-vector-length #t]
|
||||
[print-hash-table #f]
|
||||
[print-honu #f])
|
||||
(pretty-print datum (send typesetter get-output-port))
|
||||
(set! -range range)))
|
||||
|
||||
;; recompute-tables : -> void
|
||||
(define/private (recompute-tables)
|
||||
(set!-values (datum ht:flat=>stx ht:stx=>flat)
|
||||
(syntax->datum/tables main-stx primary-partition
|
||||
(length (current-colors))
|
||||
(current-suffix-option)))
|
||||
(set! identifier-list
|
||||
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))))
|
||||
(unless (syntax? stx)
|
||||
(raise-type-error 'pretty-print-syntax "syntax" stx))
|
||||
(parameterize
|
||||
([pretty-print-pre-print-hook pp-pre-hook]
|
||||
[pretty-print-post-print-hook pp-post-hook]
|
||||
[pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-current-style-table (pp-extend-style-table identifier-list)]
|
||||
[pretty-print-columns (current-default-columns)]
|
||||
;; Printing parameters (mzscheme manual 7.9.1.4)
|
||||
[print-unreadable #t]
|
||||
[print-graph #f]
|
||||
[print-struct #f]
|
||||
[print-box #t]
|
||||
[print-vector-length #t]
|
||||
[print-hash-table #f]
|
||||
[print-honu #f])
|
||||
(pretty-print datum port)
|
||||
(new range%
|
||||
(range-builder range-builder)
|
||||
(identifier-list identifier-list))))
|
||||
|
||||
;; Initialization
|
||||
(recompute-tables)
|
||||
(super-new)))
|
||||
(define (pp-print-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
((if display-like? display write) (syntax-dummy-val obj) port)]
|
||||
[(is-a? obj editor-snip%)
|
||||
(write-special obj port)]
|
||||
[else
|
||||
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
||||
|
||||
(define extended-style-list
|
||||
(define (pp-size-hook obj display-like? port)
|
||||
(cond [(is-a? obj editor-snip%)
|
||||
(pretty-print-columns)]
|
||||
[(syntax-dummy? obj)
|
||||
(let ((ostring (open-output-string)))
|
||||
((if display-like? display write) (syntax-dummy-val obj) ostring)
|
||||
(string-length (get-output-string ostring)))]
|
||||
[else #f]))
|
||||
|
||||
(define (pp-better-style-table)
|
||||
(let* ([pref (pref:tabify)]
|
||||
[table (car pref)]
|
||||
[begin-rx (cadr pref)]
|
||||
[define-rx (caddr pref)]
|
||||
[lambda-rx (cadddr pref)])
|
||||
(let ([style-list (hash-table-map table cons)])
|
||||
(pretty-print-extend-style-table
|
||||
(basic-style-list)
|
||||
(map car style-list)
|
||||
(map cdr style-list)))))
|
||||
|
||||
(define (basic-style-list)
|
||||
(pretty-print-extend-style-table
|
||||
(pretty-print-current-style-table)
|
||||
(map car basic-styles)
|
||||
(map cdr basic-styles)))
|
||||
(define basic-styles
|
||||
'((define-values . define)
|
||||
(define-syntaxes . define-syntax)))
|
||||
|
||||
(define-local-member-name range:get-ranges)
|
||||
|
||||
;; range-builder%
|
||||
(define range-builder%
|
||||
(class object%
|
||||
(define starts (make-hash-table))
|
||||
(define ranges (make-hash-table))
|
||||
|
||||
(define/public (set-start obj n)
|
||||
(hash-table-put! starts obj n))
|
||||
|
||||
(define/public (get-start obj)
|
||||
(hash-table-get starts obj (lambda _ #f)))
|
||||
|
||||
(define/public (add-range obj range)
|
||||
(hash-table-put! ranges obj (cons range (get-ranges obj))))
|
||||
|
||||
(define (get-ranges obj)
|
||||
(hash-table-get ranges obj (lambda () null)))
|
||||
|
||||
(define/public (range:get-ranges) ranges)
|
||||
|
||||
(super-new)))
|
||||
|
||||
;; range%
|
||||
(define range%
|
||||
(class* object% (range<%>)
|
||||
(init range-builder)
|
||||
(init-field identifier-list)
|
||||
(super-new)
|
||||
|
||||
(define ranges (hash-table-copy (send range-builder range:get-ranges)))
|
||||
|
||||
(define/public (get-ranges obj)
|
||||
(hash-table-get ranges obj (lambda _ null)))
|
||||
|
||||
(define/public (all-ranges)
|
||||
sorted-ranges)
|
||||
|
||||
(define/public (get-identifier-list)
|
||||
identifier-list)
|
||||
|
||||
(define sorted-ranges
|
||||
(sort
|
||||
(apply append
|
||||
(hash-table-map
|
||||
ranges
|
||||
(lambda (k vs)
|
||||
(map (lambda (v) (make-range k (car v) (cdr v))) vs))))
|
||||
(lambda (x y)
|
||||
(>= (- (range-end x) (range-start x))
|
||||
(- (range-end y) (range-start y))))))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -4,27 +4,33 @@
|
|||
"util.ss"
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "interactive-value-port.ss" "mrlib"))
|
||||
#;(lib "framework.ss" "framework")
|
||||
#;(lib "interactive-value-port.ss" "mrlib"))
|
||||
(provide properties-view%
|
||||
properties-snip%)
|
||||
|
||||
;; properties-view-base-mixin
|
||||
(define properties-view-base-mixin
|
||||
(mixin () ()
|
||||
(init)
|
||||
;; controller : controller<%>
|
||||
(init-field controller)
|
||||
|
||||
;; selected-syntax : syntax
|
||||
(field (selected-syntax #f))
|
||||
|
||||
;; set-syntax : syntax -> void
|
||||
(define/public (set-syntax stx)
|
||||
(set! selected-syntax stx)
|
||||
(refresh))
|
||||
|
||||
;; mode : maybe symbol in '(term stxobj)
|
||||
(define mode 'term)
|
||||
|
||||
;; text : text%
|
||||
(field (text (new text%)))
|
||||
(field (pdisplayer (new properties-displayer% (text text))))
|
||||
|
||||
(send controller listen-selected-syntax
|
||||
(lambda (stx)
|
||||
(set! selected-syntax stx)
|
||||
(refresh)))
|
||||
(super-new)
|
||||
|
||||
;; get-mode : -> symbol
|
||||
(define/public (get-mode) mode)
|
||||
|
||||
|
|
@ -53,17 +59,13 @@
|
|||
((term) (send pdisplayer display-meaning-info selected-syntax))
|
||||
((stxobj) (send pdisplayer display-stxobj-info selected-syntax))
|
||||
((#f) (send pdisplayer display-null-info))
|
||||
(else (error 'properties-view%:refresh "internal error: no such mode: ~s" mode))))
|
||||
|
||||
;; text : text%
|
||||
(field (text (new text%))) ;; text:wide-snip%)))
|
||||
(field (pdisplayer (new properties-displayer% (text text))))
|
||||
(else (error 'properties-view-base:refresh
|
||||
"internal error: no such mode: ~s" mode))))
|
||||
|
||||
(send text set-styles-sticky #f)
|
||||
#;(send text hide-caret #t)
|
||||
(send text lock #t)
|
||||
(refresh)
|
||||
(super-new)))
|
||||
(refresh)))
|
||||
|
||||
|
||||
;; properties-snip%
|
||||
|
|
@ -113,14 +115,13 @@
|
|||
|
||||
(super-new)
|
||||
(define tab-choices (get-tab-choices))
|
||||
(define tab-panel (new tab-panel%
|
||||
(choices (map car tab-choices))
|
||||
(parent parent)
|
||||
(callback
|
||||
(lambda (tp e)
|
||||
(set-mode
|
||||
(cdr (list-ref tab-choices (send tp get-selection))))))))
|
||||
;; canvas:wide-?%
|
||||
(define tab-panel
|
||||
(new tab-panel%
|
||||
(choices (map car tab-choices))
|
||||
(parent parent)
|
||||
(callback
|
||||
(lambda (tp e)
|
||||
(set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
|
||||
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
|
||||
|
||||
;; properties-displayer%
|
||||
|
|
@ -267,20 +268,6 @@
|
|||
'editor]
|
||||
[else s]))
|
||||
|
||||
;; make-text-port : text -> port
|
||||
;; builds a port from a text object.
|
||||
(define (make-text-port text)
|
||||
(make-output-port #f
|
||||
always-evt
|
||||
(lambda (s start end flush? enable-break?)
|
||||
(send text insert
|
||||
(bytes->string/utf-8 s #f start end))
|
||||
(- end start))
|
||||
void
|
||||
(lambda (special buffer? enable-break?)
|
||||
(send text insert special)
|
||||
#t)))
|
||||
|
||||
;; Styles
|
||||
|
||||
(define key-sd
|
||||
|
|
|
|||
|
|
@ -1,238 +1,202 @@
|
|||
|
||||
(module syntax-snip mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "match.ss")
|
||||
(lib "list.ss")
|
||||
(lib "string.ss")
|
||||
"interfaces.ss"
|
||||
"display.ss"
|
||||
"controller.ss"
|
||||
"properties.ss"
|
||||
"typesetter.ss"
|
||||
"partition.ss")
|
||||
(provide snip@
|
||||
snip-keymap-extension@)
|
||||
|
||||
;; Every snip has its own controller and properties-controller
|
||||
;; (because every snip now displays its own properties)
|
||||
(provide syntax-value-snip%)
|
||||
|
||||
(define snip@
|
||||
(unit
|
||||
(import prefs^
|
||||
keymap^
|
||||
context-menu^
|
||||
snipclass^)
|
||||
(export snip^)
|
||||
;; syntax-value-snip%
|
||||
(define syntax-value-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field host)
|
||||
(inherit set-margin
|
||||
set-inset)
|
||||
|
||||
;; syntax-snip : syntax -> snip
|
||||
(define (syntax-snip stx)
|
||||
(new syntax-snip% (syntax stx)))
|
||||
|
||||
;; syntax-value-snip%
|
||||
(define syntax-value-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field controller)
|
||||
(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)
|
||||
(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 text lock #t)
|
||||
(send text end-edit-sequence)
|
||||
(send text hide-caret #t)
|
||||
|
||||
(define -outer (new text:standard-style-list%))
|
||||
(super-new (editor -outer) (with-border? #f))
|
||||
(set-margin 0 0 0 0)
|
||||
(set-inset 2 2 2 2)
|
||||
(send -outer change-style (make-object style-delta% 'change-alignment 'top))
|
||||
(new syntax-keymap%
|
||||
(editor -outer)
|
||||
(snip this))
|
||||
(refresh)
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
(send host add-keymap text this)
|
||||
|
||||
(define/private (refresh)
|
||||
(send -outer begin-edit-sequence)
|
||||
(send -outer erase)
|
||||
(new typesetter-for-text%
|
||||
(syntax stx)
|
||||
(controller controller)
|
||||
(text -outer))
|
||||
(send -outer lock #t)
|
||||
(send -outer end-edit-sequence)
|
||||
(send -outer hide-caret #t))
|
||||
|
||||
(define/public (show-props)
|
||||
(send (send controller get-properties-controller)
|
||||
show #t))
|
||||
|
||||
(define/private outer:insert
|
||||
(case-lambda
|
||||
[(obj)
|
||||
(outer:insert obj style:normal)]
|
||||
[(text style)
|
||||
(outer:insert text style #f)]
|
||||
[(text style clickback)
|
||||
(let ([start (send -outer 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))))]))
|
||||
|
||||
;; snip% Methods
|
||||
(define/override (copy)
|
||||
(new syntax-value-snip% (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)))
|
||||
))
|
||||
;; snip% Methods
|
||||
(define/override (copy)
|
||||
(new syntax-value-snip% (host host) (syntax stx)))
|
||||
|
||||
|
||||
;; syntax-snip%
|
||||
(define syntax-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(inherit set-margin
|
||||
set-inset
|
||||
set-snipclass
|
||||
set-tight-text-fit
|
||||
show-border
|
||||
get-admin)
|
||||
|
||||
(define controller
|
||||
(new syntax-controller% (primary-partition (find-primary-partition))))
|
||||
(define properties-snip (new properties-snip%))
|
||||
(send controller set-properties-controller this)
|
||||
|
||||
(define -outer (new text%))
|
||||
(super-new (editor -outer) (with-border? #f))
|
||||
(set-margin 0 0 0 0)
|
||||
(set-inset 0 0 0 0)
|
||||
(set-snipclass snip-class)
|
||||
(send -outer select-all)
|
||||
|
||||
(define the-syntax-snip
|
||||
(new syntax-value-snip% (syntax stx) (controller controller)))
|
||||
(define the-summary
|
||||
(let ([line (syntax-line stx)]
|
||||
[col (syntax-column stx)])
|
||||
(if (and line col)
|
||||
(format "#<syntax:~s:~s>" line col)
|
||||
"#<syntax>")))
|
||||
|
||||
(define shown? #f)
|
||||
(define/public (refresh)
|
||||
(if shown?
|
||||
(refresh/shown)
|
||||
(refresh/hidden)))
|
||||
|
||||
(define/private (refresh/hidden)
|
||||
(send* -outer
|
||||
(begin-edit-sequence)
|
||||
(lock #f)
|
||||
(erase))
|
||||
(set-tight-text-fit #t)
|
||||
(show-border #f)
|
||||
(outer:insert (show-icon) style:hyper
|
||||
(lambda _ (set! shown? #t) (refresh)))
|
||||
(outer:insert the-summary)
|
||||
(send* -outer
|
||||
(lock #t)
|
||||
(end-edit-sequence)))
|
||||
|
||||
(define/private (refresh/shown)
|
||||
(send* -outer
|
||||
(begin-edit-sequence)
|
||||
(lock #f)
|
||||
(erase))
|
||||
(set-tight-text-fit #f)
|
||||
(show-border #t)
|
||||
(outer:insert (hide-icon) style:hyper
|
||||
(lambda _ (set! shown? #f) (refresh)))
|
||||
(outer:insert " ")
|
||||
(outer:insert the-syntax-snip)
|
||||
(outer:insert " ")
|
||||
(if (props-shown?)
|
||||
(begin (outer:insert "<" style:green (lambda _ (show #f)))
|
||||
(outer:insert properties-snip))
|
||||
(begin (outer:insert ">" style:green (lambda _ (show #t)))))
|
||||
(send* -outer
|
||||
(change-style (make-object style-delta% 'change-alignment 'top)
|
||||
0
|
||||
(send -outer last-position))
|
||||
(lock #t)
|
||||
(end-edit-sequence)))
|
||||
|
||||
(define/private outer:insert
|
||||
(case-lambda
|
||||
[(obj)
|
||||
(outer:insert obj style:normal)]
|
||||
[(text style)
|
||||
(outer:insert text style #f)]
|
||||
[(text style clickback)
|
||||
(let ([start (send -outer 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))))]))
|
||||
|
||||
;; 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/private (find-primary-partition)
|
||||
#;(define editor (send (get-admin) get-editor))
|
||||
(new-bound-partition))
|
||||
|
||||
|
||||
;; syntax-properties-controller methods
|
||||
(define properties-shown? #f)
|
||||
(define/public (props-shown?)
|
||||
properties-shown?)
|
||||
(define/public (show ?)
|
||||
(set! properties-shown? ?)
|
||||
(refresh))
|
||||
(define/public (set-syntax stx)
|
||||
(send properties-snip set-syntax stx))
|
||||
|
||||
(refresh)
|
||||
(send -outer hide-caret #t)
|
||||
(send -outer lock #t)
|
||||
))
|
||||
|
||||
;; independent-properties-controller%
|
||||
#;
|
||||
(define independent-properties-controller%
|
||||
(class* object% (syntax-properties-controller<%>)
|
||||
(init-field controller)
|
||||
(init-field ((stx syntax) #f))
|
||||
|
||||
;; Properties display
|
||||
(define parent
|
||||
(new frame% (label "Properties") (height (pref:height))
|
||||
(width (floor (* (pref:props-percentage) (pref:width))))))
|
||||
(define pv (new properties-view% (parent parent)))
|
||||
|
||||
(define/private (show-properties)
|
||||
(unless (send parent is-shown?)
|
||||
(send parent show #t)))
|
||||
|
||||
(define/public (set-syntax stx)
|
||||
(send pv set-syntax stx))
|
||||
(define/public (show ?)
|
||||
(send parent show ?))
|
||||
(define/public (props-shown?)
|
||||
(send parent is-shown?))
|
||||
|
||||
(super-new)))
|
||||
;; 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)))
|
||||
))
|
||||
|
||||
;; syntax-snip%
|
||||
#;
|
||||
(define syntax-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field primary-partition)
|
||||
(inherit set-margin
|
||||
set-inset
|
||||
set-snipclass
|
||||
set-tight-text-fit
|
||||
show-border
|
||||
get-admin)
|
||||
|
||||
(define properties-snip (new properties-snip%))
|
||||
|
||||
(define -outer (new text%))
|
||||
(super-new (editor -outer) (with-border? #f))
|
||||
(set-margin 0 0 0 0)
|
||||
(set-inset 0 0 0 0)
|
||||
(set-snipclass snip-class)
|
||||
(send -outer select-all)
|
||||
|
||||
(define the-syntax-snip
|
||||
(new syntax-value-snip%
|
||||
(syntax stx)
|
||||
(controller controller)
|
||||
;; FIXME
|
||||
#;(syntax-keymap% syntax-keymap%)
|
||||
))
|
||||
(define the-summary
|
||||
(let ([line (syntax-line stx)]
|
||||
[col (syntax-column stx)])
|
||||
(if (and line col)
|
||||
(format "#<syntax:~s:~s>" line col)
|
||||
"#<syntax>")))
|
||||
|
||||
(define shown? #f)
|
||||
(define/public (refresh)
|
||||
(if shown?
|
||||
(refresh/shown)
|
||||
(refresh/hidden)))
|
||||
|
||||
(define/private (refresh/hidden)
|
||||
(send* -outer
|
||||
(begin-edit-sequence)
|
||||
(lock #f)
|
||||
(erase))
|
||||
(set-tight-text-fit #t)
|
||||
(show-border #f)
|
||||
(outer:insert (show-icon) style:hyper
|
||||
(lambda _ (set! shown? #t) (refresh)))
|
||||
(outer:insert the-summary)
|
||||
(send* -outer
|
||||
(lock #t)
|
||||
(end-edit-sequence)))
|
||||
|
||||
(define/private (refresh/shown)
|
||||
(send* -outer
|
||||
(begin-edit-sequence)
|
||||
(lock #f)
|
||||
(erase))
|
||||
(set-tight-text-fit #f)
|
||||
(show-border #t)
|
||||
(outer:insert (hide-icon) style:hyper
|
||||
(lambda _ (set! shown? #f) (refresh)))
|
||||
(outer:insert " ")
|
||||
(outer:insert the-syntax-snip)
|
||||
(outer:insert " ")
|
||||
(if (props-shown?)
|
||||
(begin (outer:insert "<" style:green (lambda _ (show #f)))
|
||||
(outer:insert properties-snip))
|
||||
(begin (outer:insert ">" style:green (lambda _ (show #t)))))
|
||||
(send* -outer
|
||||
(change-style (make-object style-delta% 'change-alignment 'top)
|
||||
0
|
||||
(send -outer last-position))
|
||||
(lock #t)
|
||||
(end-edit-sequence)))
|
||||
|
||||
(define/private outer:insert
|
||||
(case-lambda
|
||||
[(obj)
|
||||
(outer:insert obj style:normal)]
|
||||
[(text style)
|
||||
(outer:insert text style #f)]
|
||||
[(text style clickback)
|
||||
(let ([start (send -outer 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))))]))
|
||||
|
||||
;; 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/private (find-primary-partition)
|
||||
#;(define editor (send (get-admin) get-editor))
|
||||
(new-bound-partition))
|
||||
|
||||
|
||||
;; syntax-properties-controller methods
|
||||
(define properties-shown? #f)
|
||||
(define/public (props-shown?)
|
||||
properties-shown?)
|
||||
(define/public (show ?)
|
||||
(set! properties-shown? ?)
|
||||
(refresh))
|
||||
(define/public (set-syntax stx)
|
||||
(send properties-snip set-syntax stx))
|
||||
|
||||
(refresh)
|
||||
(send -outer hide-caret #t)
|
||||
(send -outer lock #t)
|
||||
))
|
||||
|
||||
;; independent-properties-controller%
|
||||
#;
|
||||
(define independent-properties-controller%
|
||||
(class* object% (syntax-properties-controller<%>)
|
||||
(init-field controller)
|
||||
(init-field ((stx syntax) #f))
|
||||
|
||||
;; Properties display
|
||||
(define parent
|
||||
(new frame% (label "Properties") (height (pref:height))
|
||||
(width (floor (* (pref:props-percentage) (pref:width))))))
|
||||
(define pv (new properties-view% (parent parent)))
|
||||
|
||||
(define/private (show-properties)
|
||||
(unless (send parent is-shown?)
|
||||
(send parent show #t)))
|
||||
|
||||
(define/public (set-syntax stx)
|
||||
(send pv set-syntax stx))
|
||||
(define/public (show ?)
|
||||
(send parent show ?))
|
||||
(define/public (props-shown?)
|
||||
(send parent is-shown?))
|
||||
|
||||
(super-new)))
|
||||
|
||||
|
||||
#;
|
||||
(define snip-keymap-extension@
|
||||
(unit
|
||||
(import (prefix pre: keymap^))
|
||||
|
|
@ -243,13 +207,13 @@
|
|||
(init-field snip)
|
||||
(inherit add-function)
|
||||
(super-new (controller (send snip get-controller)))
|
||||
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send snip show-props)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define style:normal (make-object style-delta% 'change-normal))
|
||||
(define style:hyper
|
||||
(let ([s (make-object style-delta% 'change-normal)])
|
||||
|
|
@ -264,14 +228,14 @@
|
|||
(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")))
|
||||
|
|
@ -293,7 +257,7 @@
|
|||
(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)
|
||||
|
|
@ -310,4 +274,74 @@
|
|||
(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))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -6,14 +6,26 @@
|
|||
(lib "arrow.ss" "drscheme")
|
||||
(lib "framework.ss" "framework"))
|
||||
|
||||
(provide text:drawings<%>
|
||||
text:mouse-drawings<%>
|
||||
(provide text:mouse-drawings<%>
|
||||
text:arrows<%>
|
||||
|
||||
text:drawings-mixin
|
||||
text:mouse-drawings-mixin
|
||||
text:tacking-mixin
|
||||
text:arrows-mixin)
|
||||
|
||||
(define arrow-brush
|
||||
(send the-brush-list find-or-create-brush "white" 'solid))
|
||||
(define (tacked-arrow-brush color)
|
||||
(send the-brush-list find-or-create-brush color 'solid))
|
||||
|
||||
(define billboard-brush
|
||||
(send the-brush-list find-or-create-brush "white" 'solid))
|
||||
|
||||
(define white (send the-color-database find-color "white"))
|
||||
|
||||
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
|
||||
(define-struct drawing (start end draw visible? tacked?) #f)
|
||||
|
||||
(define (mean x y)
|
||||
(/ (+ x y) 2))
|
||||
|
||||
|
|
@ -45,76 +57,49 @@
|
|||
(send dc set-text-background old-background)
|
||||
(send dc set-text-mode old-mode))))
|
||||
|
||||
(define text:drawings<%>
|
||||
(interface (text:basic<%>)
|
||||
add-drawings
|
||||
delete-drawings
|
||||
delete-all-drawings))
|
||||
|
||||
(define text:mouse-drawings<%>
|
||||
(interface (text:drawings<%>)
|
||||
(interface (text:basic<%>)
|
||||
add-mouse-drawing
|
||||
delete-mouse-drawings))
|
||||
for-each-drawing
|
||||
delete-all-drawings))
|
||||
|
||||
(define text:arrows<%>
|
||||
(interface (text:mouse-drawings<%>)
|
||||
add-arrow
|
||||
add-question-arrow))
|
||||
add-question-arrow
|
||||
add-billboard))
|
||||
|
||||
(define text:drawings-mixin
|
||||
(mixin (text:basic<%>) (text:drawings<%>)
|
||||
(define draw-table (make-hash-table))
|
||||
(define text:mouse-drawings-mixin
|
||||
(mixin (text:basic<%>) (text:mouse-drawings<%>)
|
||||
(inherit dc-location-to-editor-location
|
||||
find-position
|
||||
invalidate-bitmap-cache)
|
||||
|
||||
(define/public (add-drawings key draws)
|
||||
(hash-table-put! draw-table
|
||||
key
|
||||
(append draws (hash-table-get draw-table key (lambda () null)))))
|
||||
;; list of Drawings
|
||||
(field [drawings-list null])
|
||||
|
||||
(define/public (delete-drawings key)
|
||||
(hash-table-remove! draw-table key))
|
||||
(define/public add-mouse-drawing
|
||||
(case-lambda
|
||||
[(start end draw)
|
||||
(add-mouse-drawing start end draw (box #f))]
|
||||
[(start end draw tack-box)
|
||||
(set! drawings-list
|
||||
(cons (make-drawing start end draw #f tack-box)
|
||||
drawings-list))]))
|
||||
|
||||
(define/public (delete-all-drawings)
|
||||
(for-each (lambda (key) (hash-table-remove! draw-table key))
|
||||
(hash-table-map draw-table (lambda (k v) k))))
|
||||
(set! drawings-list null))
|
||||
|
||||
(define/public-final (for-each-drawing f)
|
||||
(for-each f drawings-list))
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(hash-table-for-each
|
||||
draw-table
|
||||
(lambda (k v)
|
||||
(for-each (lambda (d) (d this dc left top right bottom dx dy))
|
||||
v)))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;; A Drawing is (make-drawing number number (??? -> void))
|
||||
(define-struct drawing (start end draw) #f)
|
||||
|
||||
(define text:mouse-drawings-mixin
|
||||
(mixin (text:drawings<%>) (text:mouse-drawings<%>)
|
||||
(inherit dc-location-to-editor-location
|
||||
find-position
|
||||
invalidate-bitmap-cache
|
||||
add-drawings
|
||||
delete-drawings)
|
||||
|
||||
;; lists of Drawings
|
||||
(field [inactive-list null]
|
||||
[active-list null])
|
||||
|
||||
(define/public (add-mouse-drawing start end draw)
|
||||
(set! inactive-list
|
||||
(cons (make-drawing start end draw)
|
||||
inactive-list)))
|
||||
|
||||
(define/public (delete-mouse-drawings)
|
||||
(set! inactive-list null))
|
||||
|
||||
(define/override (delete-all-drawings)
|
||||
(super delete-all-drawings)
|
||||
(set! inactive-list null)
|
||||
(set! active-list null))
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
|
||||
((drawing-draw d) this dc left top right bottom dx dy))))))
|
||||
|
||||
(define/override (on-default-event ev)
|
||||
(define gx (send ev get-x))
|
||||
|
|
@ -123,35 +108,69 @@
|
|||
(define pos (find-position x y))
|
||||
(super on-default-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((enter motion)
|
||||
(let ([new-active-annotations
|
||||
(filter (lambda (rec)
|
||||
(<= (drawing-start rec) pos (drawing-end rec)))
|
||||
inactive-list)])
|
||||
(unless (equal? active-list new-active-annotations)
|
||||
(set! active-list new-active-annotations)
|
||||
(delete-drawings 'mouse-over)
|
||||
(add-drawings 'mouse-over (map drawing-draw active-list))
|
||||
(invalidate-bitmap-cache))))
|
||||
((leave)
|
||||
(unless (null? active-list)
|
||||
(set! active-list null)
|
||||
(delete-drawings 'mouse-over)
|
||||
(invalidate-bitmap-cache)))))
|
||||
((enter motion leave)
|
||||
(let ([changed? (update-visible-drawings pos)])
|
||||
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))))
|
||||
|
||||
(define/private (update-visible-drawings pos)
|
||||
(let ([changed? #f])
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(let ([vis? (<= (drawing-start d) pos (drawing-end d))])
|
||||
(unless (eqv? vis? (drawing-visible? d))
|
||||
(set-drawing-visible?! d vis?)
|
||||
(set! changed? #t)))))
|
||||
changed?))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define arrow-brush (send the-brush-list find-or-create-brush "white" 'solid))
|
||||
|
||||
(define text:tacking-mixin
|
||||
(mixin (text:basic<%> text:mouse-drawings<%>) ()
|
||||
(inherit get-canvas
|
||||
for-each-drawing)
|
||||
(inherit-field drawings-list)
|
||||
(super-new)
|
||||
|
||||
(define/override (on-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((right-down)
|
||||
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
|
||||
(send (get-canvas) popup-menu
|
||||
(make-tack/untack-menu)
|
||||
(send ev get-x)
|
||||
(send ev get-y))
|
||||
(super on-event ev)))
|
||||
(else
|
||||
(super on-event ev))))
|
||||
|
||||
(define/private (make-tack/untack-menu)
|
||||
(define menu (new popup-menu%))
|
||||
(new menu-item% (label "Tack")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (tack))))
|
||||
(new menu-item% (label "Untack")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (untack))))
|
||||
menu)
|
||||
|
||||
(define/private (tack)
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #t)))))
|
||||
(define/private (untack)
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #f)))))))
|
||||
|
||||
(define text:arrows-mixin
|
||||
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
|
||||
(inherit position-location
|
||||
add-mouse-drawing
|
||||
find-wordbreak
|
||||
add-drawings
|
||||
delete-drawings
|
||||
get-canvas)
|
||||
(inherit-field active-list inactive-list)
|
||||
find-wordbreak)
|
||||
|
||||
(define/public (add-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #f))
|
||||
|
|
@ -159,36 +178,62 @@
|
|||
(define/public (add-question-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #t))
|
||||
|
||||
(define/private (internal-add-arrow from1 from2 to1 to2 color question?)
|
||||
(define/public (add-billboard pos1 pos2 str color-name)
|
||||
(define color (send the-color-database find-color color-name))
|
||||
(let ([draw
|
||||
(lambda (text dc left top right bottom dx dy)
|
||||
(let-values ([(x y) (range->mean-loc pos1 pos1)]
|
||||
[(fw fh _d _v) (send dc get-text-extent "y")])
|
||||
(with-saved-pen&brush dc
|
||||
(with-saved-text-config dc
|
||||
(send* dc
|
||||
(set-pen color 1 'solid)
|
||||
(set-brush billboard-brush)
|
||||
(set-text-mode 'solid)
|
||||
(set-font (billboard-font dc))
|
||||
(set-text-foreground color))
|
||||
(let-values ([(w h d v) (send dc get-text-extent str)]
|
||||
[(adj-y) fh]
|
||||
[(mini) _d])
|
||||
(send* dc
|
||||
(draw-rounded-rectangle
|
||||
(+ x dx)
|
||||
(+ y dy adj-y)
|
||||
(+ w mini mini)
|
||||
(+ h mini mini))
|
||||
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
|
||||
(add-mouse-drawing pos1 pos2 draw)))
|
||||
|
||||
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
|
||||
(define color (send the-color-database find-color color-name))
|
||||
(define tack-box (box #f))
|
||||
(unless (and (= from1 to1) (= from2 to2))
|
||||
(let ([draw
|
||||
(lambda (text dc left top right bottom dx dy)
|
||||
(let*-values ([(start1x start1y) (position->location from1)]
|
||||
[(start2x start2y) (position->location from2)]
|
||||
[(end1x end1y) (position->location to1)]
|
||||
[(end2x end2y) (position->location to2)]
|
||||
[(startx) (mean start1x start2x)]
|
||||
[(starty) (mean start1y start2y)]
|
||||
[(endx) (mean end1x end2x)]
|
||||
[(endy) (mean end1y end2y)]
|
||||
[(fw fh _d _v) (send dc get-text-extent "")])
|
||||
(let ([starty (+ starty (/ fh 2))]
|
||||
[endy (+ endy (/ fh 2))])
|
||||
(with-saved-pen&brush dc
|
||||
(with-saved-text-config dc
|
||||
(send dc set-pen color 1 'solid)
|
||||
(send dc set-brush arrow-brush)
|
||||
(draw-arrow dc startx starty endx endy dx dy)
|
||||
#;(send dc set-text-mode 'solid)
|
||||
(when question?
|
||||
(send dc set-font (?-font dc))
|
||||
(send dc set-text-foreground
|
||||
(send the-color-database find-color color))
|
||||
(send dc draw-text "?"
|
||||
(+ (+ startx dx) fw)
|
||||
(- (+ starty dy) fh))))))))])
|
||||
(add-mouse-drawing from1 from2 draw)
|
||||
(add-mouse-drawing to1 to2 draw))))
|
||||
(let-values ([(startx starty) (range->mean-loc from1 from2)]
|
||||
[(endx endy) (range->mean-loc to1 to2)]
|
||||
[(fw fh _d _v) (send dc get-text-extent "x")])
|
||||
(with-saved-pen&brush dc
|
||||
(with-saved-text-config dc
|
||||
(send dc set-pen color 1 'solid)
|
||||
(send dc set-brush
|
||||
(if (unbox tack-box)
|
||||
(tacked-arrow-brush color)
|
||||
arrow-brush))
|
||||
(draw-arrow dc startx
|
||||
(+ starty (/ fh 2))
|
||||
endx
|
||||
(+ endy (/ fh 2))
|
||||
dx dy)
|
||||
(send dc set-text-mode 'transparent)
|
||||
(when question?
|
||||
(send dc set-font (?-font dc))
|
||||
(send dc set-text-foreground color)
|
||||
(send dc draw-text "?"
|
||||
(+ endx dx fw)
|
||||
(- endy dy fh)))))))])
|
||||
(add-mouse-drawing from1 from2 draw tack-box)
|
||||
(add-mouse-drawing to1 to2 draw tack-box))))
|
||||
|
||||
(define/private (position->location p)
|
||||
(define xbox (box 0.0))
|
||||
|
|
@ -196,62 +241,29 @@
|
|||
(position-location p xbox ybox)
|
||||
(values (unbox xbox) (unbox ybox)))
|
||||
|
||||
(define/override (on-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((right-down)
|
||||
(let ([arrows active-list])
|
||||
(if (pair? arrows)
|
||||
(send (get-canvas) popup-menu
|
||||
(make-tack/untack-menu)
|
||||
(send ev get-x)
|
||||
(send ev get-y))
|
||||
(super on-event ev))))
|
||||
(else
|
||||
(super on-event ev))))
|
||||
|
||||
(define/private (make-tack/untack-menu)
|
||||
(define menu (new popup-menu%))
|
||||
(new menu-item% (label "Tack arrows")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (tack-arrows))))
|
||||
(new menu-item% (label "Untack arrows")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (untack-arrows))))
|
||||
menu)
|
||||
|
||||
(define/private (tack-arrows)
|
||||
(for-each (lambda (arrow)
|
||||
(add-drawings (drawing-draw arrow) (list (drawing-draw arrow))))
|
||||
active-list))
|
||||
(define/private (untack-arrows)
|
||||
(for-each (lambda (arrow) (delete-drawings (drawing-draw arrow)))
|
||||
active-list))
|
||||
|
||||
(define/private (?-font dc)
|
||||
(let ([size (send (send dc get-font) get-point-size)])
|
||||
(send the-font-list find-or-create-font size 'default 'normal 'bold)))
|
||||
|
||||
(define/private (billboard-font dc)
|
||||
(let ([size (send (send dc get-font) get-point-size)])
|
||||
(send the-font-list find-or-create-font size 'default 'normal)))
|
||||
|
||||
(define/private (range->mean-loc pos1 pos2)
|
||||
(let*-values ([(loc1x loc1y) (position->location pos1)]
|
||||
[(loc2x loc2y) (position->location pos2)]
|
||||
[(locx) (mean loc1x loc2x)]
|
||||
[(locy) (mean loc1y loc2y)])
|
||||
(values locx locy)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define text:mouse-drawings%
|
||||
(text:mouse-drawings-mixin
|
||||
(text:drawings-mixin text:standard-style-list%)))
|
||||
text:standard-style-list%))
|
||||
|
||||
(define text:arrows%
|
||||
(text:arrows-mixin text:mouse-drawings%))
|
||||
|
||||
#;
|
||||
(begin
|
||||
(define f (new frame% (label "testing") (width 100) (height 100)))
|
||||
(define t (new text:crazy% (auto-wrap #t)))
|
||||
(define ec (new editor-canvas% (parent f) (editor t)))
|
||||
(send f show #t)
|
||||
(send t insert "this is the time to remember, because it will not last forever\n")
|
||||
(send t insert "these are the days to hold on to, but we won't although we'll want to\n")
|
||||
|
||||
(send t add-dot 5)
|
||||
(send t add-arrow 25 8 "blue"))
|
||||
|
||||
(text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
text:mouse-drawings%)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -2,9 +2,12 @@
|
|||
(module util mzscheme
|
||||
(require (lib "class.ss"))
|
||||
(provide with-unlock
|
||||
make-text-port
|
||||
mpi->string
|
||||
mpi->list)
|
||||
|
||||
|
||||
;; with-unlock SYNTAX (expression)
|
||||
;; (with-unlock text-expression . body)
|
||||
(define-syntax with-unlock
|
||||
(syntax-rules ()
|
||||
[(with-unlock text . body)
|
||||
|
|
@ -14,6 +17,22 @@
|
|||
(begin0 (let () . body)
|
||||
(send t lock locked?)))]))
|
||||
|
||||
;; make-text-port : text (-> number) -> port
|
||||
;; builds a port from a text object.
|
||||
(define (make-text-port text end-position)
|
||||
(make-output-port #f
|
||||
always-evt
|
||||
(lambda (s start end flush? enable-break?)
|
||||
(send text insert
|
||||
(bytes->string/utf-8 s #f start end)
|
||||
(end-position))
|
||||
(- end start))
|
||||
void
|
||||
(lambda (special buffer? enable-break?)
|
||||
(send text insert special (end-position))
|
||||
#t)))
|
||||
|
||||
;; mpi->string : module-path-index -> string
|
||||
(define (mpi->string mpi)
|
||||
(if (module-path-index? mpi)
|
||||
(let ([mps (mpi->list mpi)])
|
||||
|
|
@ -25,7 +44,8 @@
|
|||
(format "~s" (car mps))]
|
||||
[(null? mps) "this module"]))
|
||||
(format "~s" mpi)))
|
||||
|
||||
|
||||
;; mpi->list : module-path-index -> (list-of module-spec)
|
||||
(define (mpi->list mpi)
|
||||
(if mpi
|
||||
(let-values ([(path rel) (module-path-index-split mpi)])
|
||||
|
|
@ -36,4 +56,4 @@
|
|||
[else '()]))
|
||||
'()))
|
||||
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,218 +1,232 @@
|
|||
|
||||
(module widget mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "kw.ss")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"params.ss"
|
||||
"controller.ss"
|
||||
"typesetter.ss"
|
||||
"display.ss"
|
||||
"keymap.ss"
|
||||
"hrule-snip.ss"
|
||||
"properties.ss"
|
||||
"text.ss"
|
||||
"util.ss")
|
||||
(provide widget@
|
||||
widget-keymap-extension@
|
||||
widget-context-menu-extension@)
|
||||
(provide widget%
|
||||
widget-keymap%
|
||||
widget-context-menu%)
|
||||
|
||||
(define widget@
|
||||
(unit
|
||||
(import keymap^)
|
||||
(export widget^)
|
||||
;; widget%
|
||||
;; A syntax widget creates its own syntax-controller.
|
||||
(define widget%
|
||||
(class* object% (widget-hooks<%>)
|
||||
(init parent)
|
||||
(init-field config)
|
||||
|
||||
;; syntax-widget%
|
||||
;; A syntax-widget creates its own syntax-controller.
|
||||
(define syntax-widget%
|
||||
(class* object% (syntax-browser<%> syntax-properties-controller<%>)
|
||||
(init parent)
|
||||
(init-field pref:props-percentage)
|
||||
|
||||
(define -main-panel (new vertical-panel% (parent parent)))
|
||||
(define -split-panel (new panel:horizontal-dragable% (parent -main-panel)))
|
||||
(define -text (new browser-text%))
|
||||
(define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text)))
|
||||
(define -props-panel (new horizontal-panel% (parent -split-panel)))
|
||||
(define props (new properties-view% (parent -props-panel)))
|
||||
(define props-percentage (pref:props-percentage))
|
||||
|
||||
(define controller
|
||||
(new syntax-controller%
|
||||
(properties-controller this)))
|
||||
|
||||
(define/public (make-keymap text)
|
||||
(new syntax-keymap%
|
||||
(editor text)
|
||||
(widget this)))
|
||||
(make-keymap -text)
|
||||
|
||||
(send -text lock #t)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(define controller (new controller%))
|
||||
|
||||
;; syntax-properties-controller<%> methods
|
||||
(define -main-panel
|
||||
(new vertical-panel% (parent parent)))
|
||||
(define -split-panel
|
||||
(new panel:horizontal-dragable% (parent -main-panel)))
|
||||
(define -text (new browser-text%))
|
||||
(define -ecanvas
|
||||
(new editor-canvas% (parent -split-panel) (editor -text)))
|
||||
(define -props-panel (new horizontal-panel% (parent -split-panel)))
|
||||
(define props
|
||||
(new properties-view%
|
||||
(parent -props-panel)
|
||||
(controller controller)))
|
||||
(define props-percentage (send config pref:props-percentage))
|
||||
|
||||
(define/public (set-syntax stx)
|
||||
(send props set-syntax stx))
|
||||
|
||||
(define/public (props-shown?)
|
||||
(send -props-panel is-shown?))
|
||||
|
||||
(define/public (toggle-props)
|
||||
(show-props (not (send -props-panel is-shown?))))
|
||||
|
||||
(define/public (show-props show?)
|
||||
(if show?
|
||||
(unless (send -props-panel is-shown?)
|
||||
(send -split-panel add-child -props-panel)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(send -props-panel show #t))
|
||||
(when (send -props-panel is-shown?)
|
||||
(set! props-percentage
|
||||
(cadr (send -split-panel get-percentages)))
|
||||
(send -split-panel delete-child -props-panel)
|
||||
(send -props-panel show #f))))
|
||||
(define/public (setup-keymap)
|
||||
(new widget-keymap%
|
||||
(editor -text)
|
||||
(widget this)))
|
||||
|
||||
;;
|
||||
(send -text lock #t)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
;;
|
||||
|
||||
(define/public (get-main-panel) -main-panel)
|
||||
|
||||
(define/public (save-prefs)
|
||||
(unless (= props-percentage (pref:props-percentage))
|
||||
(pref:props-percentage props-percentage)))
|
||||
|
||||
;; syntax-browser<%> Methods
|
||||
|
||||
(define/public (add-text text)
|
||||
(with-unlock -text
|
||||
(send -text insert text)))
|
||||
|
||||
(define/public add-syntax
|
||||
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
|
||||
hi2-color [hi2-stxs null])
|
||||
(when (and (pair? hi-stxs) (not hi-color))
|
||||
(error 'syntax-widget%::add-syntax "no highlight color specified"))
|
||||
(let ([colorer (internal-add-syntax stx)]
|
||||
[definite-table (make-hash-table)])
|
||||
(when (and hi2-color (pair? hi2-stxs))
|
||||
(send colorer highlight-syntaxes hi2-stxs hi2-color))
|
||||
(when (and hi-color (pair? hi-stxs))
|
||||
(send colorer highlight-syntaxes hi-stxs hi-color))
|
||||
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
|
||||
(when alpha-table
|
||||
(let ([range (send colorer get-range)])
|
||||
(for-each (lambda (id)
|
||||
(let ([binder
|
||||
(module-identifier-mapping-get alpha-table
|
||||
id
|
||||
(lambda () #f))])
|
||||
(when binder
|
||||
(for-each
|
||||
(lambda (binder-r)
|
||||
(for-each (lambda (id-r)
|
||||
(if (hash-table-get definite-table id #f)
|
||||
(send -text add-arrow
|
||||
(car id-r) (cdr id-r)
|
||||
(car binder-r) (cdr binder-r)
|
||||
"blue")
|
||||
(send -text add-question-arrow
|
||||
(car id-r) (cdr id-r)
|
||||
(car binder-r) (cdr binder-r)
|
||||
"purple")))
|
||||
(send range get-ranges id)))
|
||||
(send range get-ranges binder)))))
|
||||
(send colorer get-identifier-list))))
|
||||
colorer)))
|
||||
|
||||
(define/public (add-separator)
|
||||
(with-unlock -text
|
||||
(send* -text
|
||||
(insert (new hrule-snip%))
|
||||
(insert "\n"))))
|
||||
|
||||
(define/public (erase-all)
|
||||
(with-unlock -text
|
||||
(send -text erase)
|
||||
(send -text delete-all-drawings))
|
||||
(send controller erase))
|
||||
|
||||
(define/public (select-syntax stx)
|
||||
(send controller select-syntax stx))
|
||||
|
||||
(define/public (get-text) -text)
|
||||
|
||||
(define/private (internal-add-syntax stx)
|
||||
(with-unlock -text
|
||||
(parameterize ((current-default-columns (calculate-columns)))
|
||||
(let ([current-position (send -text last-position)])
|
||||
(let* ([new-ts (new typesetter-for-text%
|
||||
(controller controller)
|
||||
(syntax stx)
|
||||
(text -text))]
|
||||
[new-colorer (send new-ts get-colorer)])
|
||||
(send* -text
|
||||
(insert "\n")
|
||||
(scroll-to-position current-position))
|
||||
new-colorer)))))
|
||||
;; syntax-properties-controller<%> methods
|
||||
|
||||
(define/private (calculate-columns)
|
||||
(define style (code-style -text))
|
||||
(define char-width (send style get-text-width (send -ecanvas get-dc)))
|
||||
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
|
||||
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
|
||||
(define/public (set-syntax stx)
|
||||
(send props set-syntax stx))
|
||||
|
||||
(super-new)))
|
||||
(define/public (props-shown?)
|
||||
(send -props-panel is-shown?))
|
||||
|
||||
(define/public (toggle-props)
|
||||
(show-props (not (send -props-panel is-shown?))))
|
||||
|
||||
(define/public (show-props show?)
|
||||
(if show?
|
||||
(unless (send -props-panel is-shown?)
|
||||
(send -split-panel add-child -props-panel)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(send -props-panel show #t))
|
||||
(when (send -props-panel is-shown?)
|
||||
(set! props-percentage
|
||||
(cadr (send -split-panel get-percentages)))
|
||||
(send -split-panel delete-child -props-panel)
|
||||
(send -props-panel show #f))))
|
||||
|
||||
;;
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
;;
|
||||
|
||||
(define/public (get-main-panel) -main-panel)
|
||||
|
||||
(define/public (shutdown)
|
||||
(unless (= props-percentage (send config pref:props-percentage))
|
||||
(send config pref:props-percentage props-percentage)))
|
||||
|
||||
;; syntax-browser<%> Methods
|
||||
|
||||
(define/public (add-text text)
|
||||
(with-unlock -text
|
||||
(send -text insert text)))
|
||||
|
||||
(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
|
||||
(match (identifier-binding id)
|
||||
[(list src-mod src-name nom-mod nom-name _)
|
||||
(for-each (lambda (id-r)
|
||||
(send -text add-billboard
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
(string-append "from "
|
||||
(mpi->string src-mod))
|
||||
(if (hash-table-get 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)))
|
||||
|
||||
))
|
||||
(define/public (add-separator)
|
||||
(with-unlock -text
|
||||
(send* -text
|
||||
(insert (new hrule-snip%))
|
||||
(insert "\n"))))
|
||||
|
||||
(define widget-keymap-extension@
|
||||
(unit
|
||||
(import (prefix pre: keymap^))
|
||||
(export keymap^)
|
||||
(define/public (erase-all)
|
||||
(with-unlock -text
|
||||
(send -text erase)
|
||||
(send -text delete-all-drawings))
|
||||
(send controller remove-all-syntax-displays))
|
||||
|
||||
(define syntax-keymap%
|
||||
(class pre:syntax-keymap%
|
||||
(init-field widget)
|
||||
(super-new (controller (send widget get-controller)))
|
||||
(inherit add-function)
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send widget toggle-props)))
|
||||
|
||||
(define/public (get-widget) widget)
|
||||
))))
|
||||
|
||||
(define widget-context-menu-extension@
|
||||
(unit
|
||||
(import (prefix pre: context-menu^))
|
||||
(export context-menu^)
|
||||
(define/public (select-syntax stx)
|
||||
(send controller select-syntax stx))
|
||||
|
||||
(define context-menu%
|
||||
(class pre:context-menu%
|
||||
(inherit-field keymap)
|
||||
(inherit-field props-menu)
|
||||
(define/public (get-text) -text)
|
||||
|
||||
;; internal-add-syntax : syntax -> display
|
||||
(define/private (internal-add-syntax stx)
|
||||
(with-unlock -text
|
||||
(parameterize ((current-default-columns (calculate-columns)))
|
||||
(let ([display (print-syntax-to-editor stx -text controller)])
|
||||
(send* -text
|
||||
(insert "\n")
|
||||
;(scroll-to-position current-position)
|
||||
)
|
||||
display))))
|
||||
|
||||
(define/private (calculate-columns)
|
||||
(define style (code-style -text))
|
||||
(define char-width (send style get-text-width (send -ecanvas get-dc)))
|
||||
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
|
||||
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
|
||||
|
||||
;; Initialize
|
||||
(super-new)
|
||||
(setup-keymap)))
|
||||
|
||||
|
||||
;; Specialized classes for widget
|
||||
|
||||
(define widget-keymap%
|
||||
(class syntax-keymap%
|
||||
(init-field widget)
|
||||
(super-new (controller (send widget get-controller)))
|
||||
(inherit add-function)
|
||||
(inherit-field controller)
|
||||
|
||||
(define/override (get-context-menu%)
|
||||
widget-context-menu%)
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send widget toggle-props)))
|
||||
|
||||
(define/public (get-widget) widget)))
|
||||
|
||||
(define widget-context-menu%
|
||||
(class context-menu%
|
||||
(inherit-field keymap)
|
||||
(inherit-field props-menu)
|
||||
|
||||
(define/override (on-demand)
|
||||
(send props-menu set-label
|
||||
(if (send (send keymap get-widget) props-shown?)
|
||||
"Hide syntax properties"
|
||||
"Show syntax properties"))
|
||||
(super on-demand))
|
||||
(super-new)))
|
||||
|
||||
(define/override (on-demand)
|
||||
(send props-menu set-label
|
||||
(if (send (send keymap get-widget) props-shown?)
|
||||
"Hide syntax properties"
|
||||
"Show syntax properties"))
|
||||
(super on-demand))
|
||||
(super-new)))))
|
||||
|
||||
(define browser-text%
|
||||
(text:arrows-mixin
|
||||
(text:mouse-drawings-mixin
|
||||
(text:drawings-mixin
|
||||
(text:hide-caret/selection-mixin
|
||||
(editor:standard-style-list-mixin text:basic%))))))
|
||||
(class (text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
(text:mouse-drawings-mixin
|
||||
(text:hide-caret/selection-mixin
|
||||
(editor:standard-style-list-mixin text:basic%)))))
|
||||
(define/override (default-style-name) "Basic")
|
||||
(super-new)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(provide cursor?
|
||||
cursor:new
|
||||
cursor:add-to-end!
|
||||
cursor:remove-current!
|
||||
|
||||
cursor:next
|
||||
cursor:prev
|
||||
|
|
@ -64,6 +65,10 @@
|
|||
(let ([suffix (cursor-suffixp c)])
|
||||
(set-cursor-suffixp! c (stream-append suffix items))))
|
||||
|
||||
(define (cursor:remove-current! c)
|
||||
(when (cursor:has-next? c)
|
||||
(set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
|
||||
|
||||
(define (cursor:next c)
|
||||
(let ([suffix (cursor-suffixp c)])
|
||||
(if (stream-null? suffix)
|
||||
|
|
|
|||
112
collects/macro-debugger/view/extensions.ss
Normal file
112
collects/macro-debugger/view/extensions.ss
Normal file
|
|
@ -0,0 +1,112 @@
|
|||
|
||||
(module extensions mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix s: "../syntax-browser/widget.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"util.ss")
|
||||
(provide stepper-keymap%
|
||||
stepper-context-menu%
|
||||
stepper-syntax-widget%)
|
||||
|
||||
;; Extensions
|
||||
|
||||
(define stepper-keymap%
|
||||
(class s:widget-keymap%
|
||||
(init-field macro-stepper)
|
||||
(inherit-field controller)
|
||||
(inherit add-function)
|
||||
|
||||
(super-new)
|
||||
|
||||
(define/override (get-context-menu%)
|
||||
stepper-context-menu%)
|
||||
|
||||
(define/public (get-hiding-panel)
|
||||
(send macro-stepper get-macro-hiding-prefs))
|
||||
|
||||
(add-function "hiding:show-macro"
|
||||
(lambda (i e)
|
||||
(send* (get-hiding-panel)
|
||||
(add-show-identifier)
|
||||
(refresh))))
|
||||
|
||||
(add-function "hiding:hide-macro"
|
||||
(lambda (i e)
|
||||
(send* (get-hiding-panel)
|
||||
(add-hide-identifier)
|
||||
(refresh))))))
|
||||
|
||||
(define stepper-context-menu%
|
||||
(class s:widget-context-menu%
|
||||
(inherit-field keymap)
|
||||
(inherit add-separator)
|
||||
|
||||
(field [show-macro #f]
|
||||
[hide-macro #f])
|
||||
|
||||
(define/override (after-selection-items)
|
||||
(super after-selection-items)
|
||||
(add-separator)
|
||||
(set! show-macro
|
||||
(new menu-item% (label "Show this macro") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:show-macro" i e)))))
|
||||
(set! hide-macro
|
||||
(new menu-item% (label "Hide this macro") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:hide-macro" i e)))))
|
||||
(void))
|
||||
|
||||
(define/override (on-demand)
|
||||
(define hiding-panel (send keymap get-hiding-panel))
|
||||
(define controller (send keymap get-controller))
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(define id? (identifier? stx))
|
||||
(send show-macro enable id?)
|
||||
(send hide-macro enable id?)
|
||||
(super on-demand))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define stepper-syntax-widget%
|
||||
(class s:widget%
|
||||
(init-field macro-stepper)
|
||||
(inherit get-text)
|
||||
|
||||
(define/override (setup-keymap)
|
||||
(new stepper-keymap%
|
||||
(editor (get-text))
|
||||
(widget this)
|
||||
(macro-stepper macro-stepper)))
|
||||
|
||||
(define/override (show-props show?)
|
||||
(super show-props show?)
|
||||
(send macro-stepper update/preserve-view))
|
||||
|
||||
(super-new
|
||||
(config (new config-adapter%
|
||||
(config (send macro-stepper get-config)))))))
|
||||
|
||||
(define config-adapter%
|
||||
(class object%
|
||||
(init-field config)
|
||||
(define/public pref:props-percentage
|
||||
(case-lambda [() (send config get-props-percentage)]
|
||||
[(v) (send config set-props-percentage v)]))
|
||||
(super-new)))
|
||||
)
|
||||
239
collects/macro-debugger/view/frame.ss
Normal file
239
collects/macro-debugger/view/frame.ss
Normal file
|
|
@ -0,0 +1,239 @@
|
|||
|
||||
(module frame mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
(lib "file.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"stepper.ss"
|
||||
"prefs.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix sb: "../syntax-browser/embed.ss")
|
||||
(prefix sb: "../syntax-browser/params.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"util.ss")
|
||||
(provide macro-stepper-frame-mixin)
|
||||
|
||||
(define (macro-stepper-frame-mixin base-frame%)
|
||||
(class base-frame%
|
||||
(init-field config)
|
||||
(init-field (filename #f))
|
||||
|
||||
(define obsoleted? #f)
|
||||
|
||||
(inherit get-area-container
|
||||
set-label
|
||||
get-menu%
|
||||
get-menu-item%
|
||||
get-menu-bar
|
||||
get-file-menu
|
||||
get-edit-menu
|
||||
get-help-menu)
|
||||
|
||||
(super-new (label (make-label))
|
||||
(width (send config get-width))
|
||||
(height (send config get-height)))
|
||||
|
||||
(define/private (make-label)
|
||||
(if filename
|
||||
(string-append (path->string
|
||||
(file-name-from-path filename))
|
||||
(if obsoleted? " (old)" "")
|
||||
" - Macro stepper")
|
||||
"Macro stepper"))
|
||||
|
||||
(define/override (on-size w h)
|
||||
(send config set-width w)
|
||||
(send config set-height h)
|
||||
(send widget update/preserve-view))
|
||||
|
||||
(define/augment (on-close)
|
||||
(send widget shutdown)
|
||||
(inner (void) on-close))
|
||||
|
||||
(override/return-false file-menu:create-new?
|
||||
file-menu:create-open?
|
||||
file-menu:create-open-recent?
|
||||
file-menu:create-revert?
|
||||
file-menu:create-save?
|
||||
file-menu:create-save-as?
|
||||
;file-menu:create-print?
|
||||
edit-menu:create-undo?
|
||||
edit-menu:create-redo?
|
||||
;edit-menu:create-cut?
|
||||
;edit-menu:create-paste?
|
||||
edit-menu:create-clear?
|
||||
;edit-menu:create-find?
|
||||
;edit-menu:create-find-again?
|
||||
edit-menu:create-replace-and-find-again?)
|
||||
|
||||
(define file-menu (get-file-menu))
|
||||
(define edit-menu (get-edit-menu))
|
||||
(define stepper-menu
|
||||
(new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
|
||||
(define help-menu (get-help-menu))
|
||||
|
||||
(define warning-panel
|
||||
(new horizontal-panel%
|
||||
(parent (get-area-container))
|
||||
(stretchable-height #f)
|
||||
(style '(deleted))))
|
||||
|
||||
(define widget
|
||||
(new macro-stepper-widget%
|
||||
(parent (get-area-container))
|
||||
(config config)))
|
||||
|
||||
(define/public (get-widget) widget)
|
||||
|
||||
(define/public (add-obsoleted-warning)
|
||||
(unless obsoleted?
|
||||
(set! obsoleted? #t)
|
||||
(new warning-canvas%
|
||||
(warning
|
||||
(string-append
|
||||
"Warning: This macro stepper session is obsolete. "
|
||||
"The program may have changed."))
|
||||
(parent warning-panel))
|
||||
(set-label (make-label))
|
||||
(send (get-area-container) change-children
|
||||
(lambda (children)
|
||||
(cons warning-panel
|
||||
(remq warning-panel children))))))
|
||||
|
||||
;; Set up menus
|
||||
|
||||
(menu-option/notify-box stepper-menu
|
||||
"Show syntax properties"
|
||||
(get-field show-syntax-properties? config))
|
||||
|
||||
;; FIXME: rewrite with notify-box
|
||||
(let ([id-menu
|
||||
(new (get-menu%)
|
||||
(label "Identifier=?")
|
||||
(parent stepper-menu))])
|
||||
(for-each (lambda (p)
|
||||
(let ([this-choice
|
||||
(new checkable-menu-item%
|
||||
(label (car p))
|
||||
(parent id-menu)
|
||||
(callback
|
||||
(lambda _
|
||||
(send (send widget get-controller)
|
||||
on-update-identifier=?
|
||||
(car p)
|
||||
(cdr p)))))])
|
||||
(send (send widget get-controller)
|
||||
listen-identifier=?
|
||||
(lambda (name+func)
|
||||
(send this-choice check
|
||||
(eq? (car name+func) (car p)))))))
|
||||
(sb:identifier=-choices)))
|
||||
(let ([identifier=? (send config get-identifier=?)])
|
||||
(when identifier=?
|
||||
(let ([p (assoc identifier=? (sb:identifier=-choices))])
|
||||
(send (send widget get-controller) set-identifier=? p))))
|
||||
|
||||
(new (get-menu-item%)
|
||||
(label "Clear selection")
|
||||
(parent stepper-menu)
|
||||
(callback
|
||||
(lambda _ (send (send widget get-controller) select-syntax #f))))
|
||||
(new separator-menu-item% (parent stepper-menu))
|
||||
|
||||
(menu-option/notify-box stepper-menu
|
||||
"Show macro hiding panel"
|
||||
(get-field show-hiding-panel? config))
|
||||
#;
|
||||
(new (get-menu-item%)
|
||||
(label "Show in new frame")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget show-in-new-frame))))
|
||||
(new (get-menu-item%)
|
||||
(label "Remove selected term")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget remove-current-term))))
|
||||
(new (get-menu-item%)
|
||||
(label "Reset mark numbering")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget reset-primary-partition))))
|
||||
(let ([extras-menu
|
||||
(new (get-menu%)
|
||||
(label "Extra options")
|
||||
(parent stepper-menu))])
|
||||
(new checkable-menu-item%
|
||||
(label "Always suffix marked identifiers")
|
||||
(parent extras-menu)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(sb:current-suffix-option
|
||||
(if (send i is-checked?)
|
||||
'always
|
||||
'over-limit))
|
||||
(send widget update/preserve-view))))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Highlight redex/contractum"
|
||||
(get-field highlight-foci? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Highlight frontier"
|
||||
(get-field highlight-frontier? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Include renaming steps"
|
||||
(get-field show-rename-steps? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"One term at a time"
|
||||
(get-field one-by-one? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Suppress warnings"
|
||||
(get-field suppress-warnings? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Extra navigation"
|
||||
(get-field extra-navigation? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Force block->letrec transformation"
|
||||
(get-field force-letrec-transformation? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"(Debug) Catch internal errors?"
|
||||
(get-field debug-catch-errors? config)))
|
||||
|
||||
(frame:reorder-menus this)))
|
||||
|
||||
;; Stolen from stepper
|
||||
|
||||
(define warning-color "yellow")
|
||||
(define warning-font normal-control-font)
|
||||
|
||||
(define warning-canvas%
|
||||
(class canvas%
|
||||
(init-field warning)
|
||||
(inherit get-dc get-client-size)
|
||||
(define/override (on-paint)
|
||||
(let ([dc (get-dc)])
|
||||
(send dc set-font warning-font)
|
||||
(let-values ([(cw ch) (get-client-size)]
|
||||
[(tw th dont-care dont-care2) (send dc get-text-extent warning)])
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
|
||||
(send dc draw-rectangle 0 0 cw ch)
|
||||
(send dc draw-text
|
||||
warning
|
||||
(- (/ cw 2) (/ tw 2))
|
||||
(- (/ ch 2) (/ th 2))))))
|
||||
(super-new)
|
||||
(inherit min-width min-height stretchable-height)
|
||||
(let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)])
|
||||
(min-width (+ 2 (inexact->exact (ceiling tw))))
|
||||
(min-height (+ 2 (inexact->exact (ceiling th)))))
|
||||
(stretchable-height #f)))
|
||||
|
||||
)
|
||||
|
|
@ -5,10 +5,54 @@
|
|||
(lib "list.ss")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"util.ss"
|
||||
"../model/hiding-policies.ss"
|
||||
"../model/synth-engine.ss"
|
||||
"../syntax-browser/util.ss")
|
||||
(provide macro-hiding-prefs-widget%)
|
||||
|
||||
|
||||
(define mode:disable "Disable")
|
||||
(define mode:standard "Standard")
|
||||
(define mode:custom "Custom ...")
|
||||
|
||||
(define (make-policy hide-mzscheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-transformers?
|
||||
specialized-policies)
|
||||
(lambda (id)
|
||||
(define now (phase))
|
||||
(define binding
|
||||
(cond [(= now 0) (identifier-binding id)]
|
||||
[(= now 1) (identifier-transformer-binding id)]
|
||||
[else #f]))
|
||||
(define-values (def-mod def-name nom-mod nom-name)
|
||||
(if (pair? binding)
|
||||
(values (car binding)
|
||||
(cadr binding)
|
||||
(caddr binding)
|
||||
(cadddr binding))
|
||||
(values #f #f #f #f)))
|
||||
(let/ec return
|
||||
(let loop ([policies specialized-policies])
|
||||
(when (pair? policies)
|
||||
((car policies) id binding return)
|
||||
(loop (cdr policies))))
|
||||
(cond [(and hide-mzscheme? (symbol? def-mod)
|
||||
(regexp-match #rx"^#%" (symbol->string def-mod)))
|
||||
#f]
|
||||
[(and hide-libs? def-mod
|
||||
(lib-module? def-mod))
|
||||
#f]
|
||||
[(and hide-contracts? def-name
|
||||
(regexp-match #rx"^provide/contract-id-"
|
||||
(symbol->string def-name)))
|
||||
#f]
|
||||
[(and hide-transformers? (positive? now))
|
||||
#f]
|
||||
[else #t]))))
|
||||
|
||||
(define standard-policy
|
||||
(make-policy #t #t #t #t null))
|
||||
|
||||
;; macro-hiding-prefs-widget%
|
||||
(define macro-hiding-prefs-widget%
|
||||
(class object%
|
||||
|
|
@ -16,200 +60,269 @@
|
|||
(init-field stepper)
|
||||
(init-field config)
|
||||
|
||||
(define policy (new-hiding-policy))
|
||||
(set-hiding-policy-opaque-kernel! policy (send config get-hide-primitives?))
|
||||
(set-hiding-policy-opaque-libs! policy (send config get-hide-libs?))
|
||||
(send config listen-hide-primitives?
|
||||
(lambda (value)
|
||||
(set-hiding-policy-opaque-kernel! policy value)
|
||||
(refresh)))
|
||||
(send config listen-hide-libs?
|
||||
(lambda (value)
|
||||
(set-hiding-policy-opaque-libs! policy value)
|
||||
(refresh)))
|
||||
(define/public (get-policy)
|
||||
(let ([mode (get-mode)])
|
||||
(cond [(not (macro-hiding-enabled?)) #f]
|
||||
[(equal? mode mode:standard) standard-policy]
|
||||
[(equal? mode mode:custom) (get-custom-policy)])))
|
||||
|
||||
(define stx #f)
|
||||
(define stx-name #f)
|
||||
(define stx-module #f)
|
||||
(define/private (get-custom-policy)
|
||||
(let ([hide-mzscheme? (send box:hide-mzscheme get-value)]
|
||||
[hide-libs? (send box:hide-libs get-value)]
|
||||
[hide-contracts? (send box:hide-contracts get-value)]
|
||||
[hide-transformers? (send box:hide-phase1 get-value)]
|
||||
[specialized-policies (get-specialized-policies)])
|
||||
(make-policy hide-mzscheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-transformers?
|
||||
specialized-policies)))
|
||||
|
||||
(define super-pane
|
||||
(new horizontal-pane%
|
||||
(define super-panel
|
||||
(new vertical-panel%
|
||||
(parent parent)
|
||||
(stretchable-height #f)))
|
||||
(define top-line-panel
|
||||
(new horizontal-panel%
|
||||
(parent super-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-height #f)))
|
||||
(define customize-panel
|
||||
(new horizontal-panel%
|
||||
(parent super-panel)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left top))
|
||||
(style '(deleted))))
|
||||
(define left-pane
|
||||
(new vertical-pane%
|
||||
(parent super-pane)
|
||||
(parent customize-panel)
|
||||
(stretchable-width #f)
|
||||
(alignment '(left top))))
|
||||
(define right-pane
|
||||
(new vertical-pane%
|
||||
(parent super-pane)))
|
||||
(parent customize-panel)))
|
||||
|
||||
(define enable-ctl
|
||||
(check-box/notify-box left-pane
|
||||
"Enable macro hiding?"
|
||||
(get-field macro-hiding? config)))
|
||||
(send config listen-macro-hiding?
|
||||
(lambda (value) (force-refresh)))
|
||||
(define mode-selector
|
||||
(choice/notify-box
|
||||
top-line-panel
|
||||
"Macro hiding: "
|
||||
(list mode:disable mode:standard mode:custom)
|
||||
(get-field macro-hiding-mode config)))
|
||||
(define top-line-inner-panel
|
||||
(new horizontal-panel%
|
||||
(parent top-line-panel)
|
||||
(alignment '(right center))
|
||||
(style '(deleted))))
|
||||
|
||||
(define kernel-ctl
|
||||
(check-box/notify-box left-pane
|
||||
"Hide mzscheme syntax"
|
||||
(get-field hide-primitives? config)))
|
||||
(define/private (get-mode)
|
||||
(send config get-macro-hiding-mode))
|
||||
|
||||
(define libs-ctl
|
||||
(check-box/notify-box left-pane
|
||||
"Hide library syntax"
|
||||
(get-field hide-libs? config)))
|
||||
(define/private (macro-hiding-enabled?)
|
||||
(let ([mode (get-mode)])
|
||||
(or (equal? mode mode:standard)
|
||||
(and (equal? mode mode:custom)
|
||||
(send box:hiding get-value)))))
|
||||
|
||||
(define/private (ensure-custom-mode)
|
||||
(unless (equal? (get-mode) mode:custom)
|
||||
(send config set-macro-hiding-mode mode:custom)))
|
||||
|
||||
(define/private (update-visibility)
|
||||
(let ([customizing (equal? (get-mode) mode:custom)])
|
||||
(send top-line-panel change-children
|
||||
(lambda (children)
|
||||
(append (remq top-line-inner-panel children)
|
||||
(if customizing (list top-line-inner-panel) null))))
|
||||
(send super-panel change-children
|
||||
(lambda (children)
|
||||
(append (remq customize-panel children)
|
||||
(if (and customizing (send box:edit get-value))
|
||||
(list customize-panel)
|
||||
null))))))
|
||||
|
||||
(send config listen-macro-hiding-mode
|
||||
(lambda (value)
|
||||
(update-visibility)
|
||||
(force-refresh)))
|
||||
|
||||
(define box:hiding
|
||||
(new check-box%
|
||||
(label "Enable macro hiding")
|
||||
(value #t)
|
||||
(parent top-line-inner-panel)
|
||||
(callback (lambda (c e) (force-refresh)))))
|
||||
(define box:edit
|
||||
(new check-box%
|
||||
(label "Show policy editor")
|
||||
(parent top-line-inner-panel)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (update-visibility)))))
|
||||
|
||||
(define box:hide-mzscheme
|
||||
(new check-box%
|
||||
(label "Hide mzscheme syntax")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-libs
|
||||
(new check-box%
|
||||
(label "Hide library syntax")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-contracts
|
||||
(new check-box%
|
||||
(label "Hide contracts (heuristic)")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-phase1
|
||||
(new check-box%
|
||||
(label "Hide phase>0")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
|
||||
(define look-pane
|
||||
(new horizontal-pane% (parent right-pane) (stretchable-height #f)))
|
||||
(define look-ctl
|
||||
(new list-box% (parent look-pane) (label "") (choices null)))
|
||||
(define delete-ctl
|
||||
(new button% (parent look-pane) (label "Delete")
|
||||
(new list-box% (parent right-pane) (label "")
|
||||
(choices null) (style '(extended))
|
||||
(callback
|
||||
(lambda _
|
||||
(delete-selected)
|
||||
(refresh)))))
|
||||
|
||||
(define add-pane
|
||||
(new horizontal-pane% (parent right-pane) (stretchable-height #f)))
|
||||
(define add-text
|
||||
(new text-field%
|
||||
(label "")
|
||||
(parent add-pane)
|
||||
(stretchable-width #t)))
|
||||
(define add-editor (send add-text get-editor))
|
||||
(define add-hide-module-button
|
||||
(new button% (parent add-pane) (label "Hide module") (enabled #f)
|
||||
(callback (lambda _ (add-hide-module) (refresh)))))
|
||||
(lambda (c e)
|
||||
(send delete-ctl enable (pair? (send c get-selections)))))))
|
||||
|
||||
(define look-button-pane
|
||||
(new horizontal-pane% (parent right-pane) (stretchable-width #f)))
|
||||
|
||||
(define delete-ctl
|
||||
(new button% (parent look-button-pane) (label "Delete rule") (enabled #f)
|
||||
(callback (lambda _ (delete-selected) (refresh)))))
|
||||
(define add-hide-id-button
|
||||
(new button% (parent add-pane) (label "Hide macro") (enabled #f)
|
||||
(new button% (parent look-button-pane) (label "Hide macro") (enabled #f)
|
||||
(callback (lambda _ (add-hide-identifier) (refresh)))))
|
||||
(define add-show-id-button
|
||||
(new button% (parent add-pane) (label "Show macro") (enabled #f)
|
||||
(new button% (parent look-button-pane) (label "Show macro") (enabled #f)
|
||||
(callback (lambda _ (add-show-identifier) (refresh)))))
|
||||
|
||||
(new grow-box-spacer-pane% (parent add-pane))
|
||||
|
||||
(send add-editor lock #t)
|
||||
#;(new grow-box-spacer-pane% (parent right-pane))
|
||||
|
||||
;; Methods
|
||||
|
||||
(define/public (get-show-macro?)
|
||||
(lambda (id) (policy-show-macro? policy id)))
|
||||
|
||||
;; refresh
|
||||
|
||||
(define stx #f)
|
||||
(define stx-name #f)
|
||||
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(when (send config get-macro-hiding?)
|
||||
(when (macro-hiding-enabled?)
|
||||
(send stepper refresh/resynth)))
|
||||
|
||||
;; force-refresh
|
||||
;; force-refresh : -> void
|
||||
(define/private (force-refresh)
|
||||
(send stepper refresh/resynth))
|
||||
|
||||
;; set-syntax : syntax/#f -> void
|
||||
(define/public (set-syntax lstx)
|
||||
(set! stx lstx)
|
||||
(send add-editor lock #f)
|
||||
(send add-editor erase)
|
||||
(unless (identifier? stx)
|
||||
(send add-hide-module-button enable #f))
|
||||
(set! stx (and (identifier? lstx) lstx))
|
||||
(when (identifier? stx)
|
||||
(let ([binding (identifier-binding stx)])
|
||||
(send add-hide-module-button enable (pair? binding))
|
||||
(if (pair? binding)
|
||||
(begin
|
||||
(set! stx-name (cadr binding))
|
||||
(set! stx-module (car binding)))
|
||||
(begin
|
||||
(set! stx-name (syntax-e stx))
|
||||
(set! stx-module #f)))
|
||||
(update-add-text)))
|
||||
(send add-editor lock #t)
|
||||
(set! stx-name (cadr binding))
|
||||
(set! stx-name (syntax-e stx)))))
|
||||
(send add-show-id-button enable (identifier? lstx))
|
||||
(send add-hide-id-button enable (identifier? lstx)))
|
||||
|
||||
(define/private (update-add-text)
|
||||
(send add-editor lock #f)
|
||||
(when (identifier? stx)
|
||||
(send add-editor insert (identifier-text "" stx)))
|
||||
(send add-editor lock #t))
|
||||
|
||||
(define/public (add-hide-module)
|
||||
(when stx-module
|
||||
(policy-hide-module policy stx-module)
|
||||
(update-list-view)))
|
||||
|
||||
|
||||
(define identifier-policies null)
|
||||
|
||||
(define/private (get-specialized-policies)
|
||||
(map (lambda (policy)
|
||||
(define key (car policy))
|
||||
(define show? (cdr policy))
|
||||
(cond [(pair? key)
|
||||
(lambda (id binding return)
|
||||
(when (and (pair? binding)
|
||||
(equal? key (get-id-key/binding id binding)))
|
||||
(return show?)))]
|
||||
[else
|
||||
(lambda (id binding return)
|
||||
(when (module-identifier=? id key)
|
||||
(return show?)))]))
|
||||
identifier-policies))
|
||||
|
||||
(define/public (add-hide-identifier)
|
||||
(when (identifier? stx)
|
||||
(policy-hide-id policy stx)
|
||||
(update-list-view)))
|
||||
|
||||
(add-identifier-policy #f)
|
||||
(ensure-custom-mode))
|
||||
|
||||
(define/public (add-show-identifier)
|
||||
(add-identifier-policy #t)
|
||||
(ensure-custom-mode))
|
||||
|
||||
(define/private (add-identifier-policy show?)
|
||||
(when (identifier? stx)
|
||||
(policy-show-id policy stx)
|
||||
(update-list-view)))
|
||||
|
||||
(let ([key (get-id-key stx)])
|
||||
(let loop ([i 0] [policies identifier-policies])
|
||||
(cond [(null? policies)
|
||||
(set! identifier-policies
|
||||
(cons (cons key show?) identifier-policies))
|
||||
(send look-ctl append "")
|
||||
(update-list-view i key show?)]
|
||||
[(key=? key (car (car policies)))
|
||||
(set-cdr! (car policies) show?)
|
||||
(update-list-view i key show?)]
|
||||
[else (loop (add1 i) (cdr policies))])))))
|
||||
|
||||
(define/private (update-list-view index key show?)
|
||||
(send look-ctl set-data index key)
|
||||
(send look-ctl set-string
|
||||
index
|
||||
(string-append (if show? "show " "hide ")
|
||||
(key->text key))))
|
||||
|
||||
(define/private (delete-selected)
|
||||
(for-each (lambda (n)
|
||||
(let ([d (send look-ctl get-data n)])
|
||||
(case (car d)
|
||||
((identifier) (policy-unhide-id policy (cdr d)))
|
||||
((show-identifier) (policy-unshow-id policy (cdr d)))
|
||||
((module) (policy-unhide-module policy (cdr d))))))
|
||||
(send look-ctl get-selections))
|
||||
(update-list-view))
|
||||
|
||||
(define/private (identifier-text prefix id)
|
||||
(let ([b (identifier-binding id)])
|
||||
(cond [(pair? b)
|
||||
(let ([name (cadr b)]
|
||||
[mod (car b)])
|
||||
(format "~a'~s' from ~a"
|
||||
prefix
|
||||
name
|
||||
(mpi->string mod)))]
|
||||
[(eq? b 'lexical)
|
||||
(format "~alexically bound '~s'"
|
||||
prefix
|
||||
(syntax-e id))]
|
||||
[(not b)
|
||||
(format "~aglobal or unbound '~s'" prefix (syntax-e id))])))
|
||||
|
||||
(define/private (update-list-view)
|
||||
(let ([opaque-modules
|
||||
(hash-table-map (hiding-policy-opaque-modules policy)
|
||||
(lambda (k v) k))]
|
||||
[opaque-ids
|
||||
(filter values
|
||||
(module-identifier-mapping-map
|
||||
(hiding-policy-opaque-ids policy)
|
||||
(lambda (k v) (and v k))))]
|
||||
[transparent-ids
|
||||
(filter values
|
||||
(module-identifier-mapping-map
|
||||
(hiding-policy-transparent-ids policy)
|
||||
(lambda (k v) (and v k))))])
|
||||
(define (om s)
|
||||
(cons (format "hide from module ~a" (mpi->string s))
|
||||
(cons 'module s)))
|
||||
(define (*i prefix tag id)
|
||||
(cons (identifier-text prefix id)
|
||||
(cons tag id)))
|
||||
(define (oid id) (*i "hide " 'identifier id))
|
||||
(define (tid id) (*i "show " 'show-identifier id))
|
||||
(let ([choices
|
||||
(sort (append (map om opaque-modules)
|
||||
(map oid opaque-ids)
|
||||
(map tid transparent-ids))
|
||||
(lambda (a b)
|
||||
(string<=? (car a) (car b))))])
|
||||
(send look-ctl clear)
|
||||
(for-each (lambda (c) (send look-ctl append (car c) (cdr c)))
|
||||
choices))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define to-delete (sort (send look-ctl get-selections) <))
|
||||
(set! identifier-policies
|
||||
(let loop ([i 0] [policies identifier-policies] [to-delete to-delete])
|
||||
(cond [(null? to-delete) policies]
|
||||
[(= i (car to-delete))
|
||||
(loop (add1 i) (cdr policies) (cdr to-delete))]
|
||||
[else
|
||||
(cons (car policies)
|
||||
(loop (add1 i) (cdr policies) to-delete))])))
|
||||
(for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))
|
||||
|
||||
(super-new)
|
||||
(update-visibility)))
|
||||
|
||||
(define (lib-module? mpi)
|
||||
(and (module-path-index? mpi)
|
||||
(let-values ([(path rel) (module-path-index-split mpi)])
|
||||
(cond [(pair? path) (memq (car path) '(lib planet))]
|
||||
[(string? path) (lib-module? rel)]
|
||||
[else #f]))))
|
||||
|
||||
(define (get-id-key id)
|
||||
(let ([binding
|
||||
(or (identifier-binding id)
|
||||
(identifier-transformer-binding id))])
|
||||
(get-id-key/binding id binding)))
|
||||
|
||||
(define (get-id-key/binding id binding)
|
||||
(cond [(pair? binding)
|
||||
binding]
|
||||
[else id]))
|
||||
|
||||
(define (key=? key1 key2)
|
||||
(cond [(and (identifier? key1) (identifier? key2))
|
||||
(module-identifier=? key1 key2)]
|
||||
[(and (pair? key1) (pair? key2))
|
||||
(and (equal? (car key1) (car key2))
|
||||
(equal? (cadr key1) (cadr key2)))]
|
||||
[else #f]))
|
||||
|
||||
(define (key->text key)
|
||||
(cond [(pair? key)
|
||||
(let ([name (cadddr key)]
|
||||
[mod (caddr key)])
|
||||
(format "'~s' from ~a"
|
||||
name
|
||||
(mpi->string mod)))]
|
||||
[else (symbol->string (syntax-e key))]))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -19,11 +19,9 @@
|
|||
(pref:width
|
||||
pref:height
|
||||
pref:props-percentage
|
||||
pref:macro-hiding?
|
||||
pref:macro-hiding-mode
|
||||
pref:show-syntax-properties?
|
||||
pref:show-hiding-panel?
|
||||
pref:hide-primitives?
|
||||
pref:hide-libs?
|
||||
pref:identifier=?
|
||||
pref:show-rename-steps?
|
||||
pref:highlight-foci?
|
||||
|
|
|
|||
|
|
@ -1,26 +1,19 @@
|
|||
|
||||
(module prefs mzscheme
|
||||
(require (lib "unit.ss")
|
||||
(require (lib "class.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"interfaces.ss")
|
||||
(provide prefs@)
|
||||
|
||||
(define-syntax pref:get/set
|
||||
(syntax-rules ()
|
||||
[(_ get/set prop)
|
||||
(define get/set
|
||||
(case-lambda
|
||||
[() (preferences:get 'prop)]
|
||||
[(newval) (preferences:set 'prop newval)]))]))
|
||||
"../util/notify.ss"
|
||||
"../util/misc.ss")
|
||||
(provide macro-stepper-config-base%
|
||||
macro-stepper-config/prefs%
|
||||
macro-stepper-config/prefs/readonly%)
|
||||
|
||||
(preferences:set-default 'MacroStepper:Frame:Width 700 number?)
|
||||
(preferences:set-default 'MacroStepper:Frame:Height 600 number?)
|
||||
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'MacroStepper:MacroHiding? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
|
||||
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:HideLibs? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
|
||||
(preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?)
|
||||
|
|
@ -31,28 +24,77 @@
|
|||
(preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
|
||||
|
||||
(define prefs@
|
||||
(unit
|
||||
(import)
|
||||
(export prefs^)
|
||||
|
||||
(pref:get/set pref:width MacroStepper:Frame:Width)
|
||||
(pref:get/set pref:height MacroStepper:Frame:Height)
|
||||
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
|
||||
(pref:get/set pref:macro-hiding? MacroStepper:MacroHiding?)
|
||||
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
|
||||
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
|
||||
(pref:get/set pref:hide-primitives? MacroStepper:HidePrimitives?)
|
||||
(pref:get/set pref:hide-libs? MacroStepper:HideLibs?)
|
||||
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
|
||||
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
|
||||
(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?)
|
||||
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
|
||||
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
|
||||
(pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
|
||||
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
|
||||
(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
|
||||
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
|
||||
|
||||
))
|
||||
(pref:get/set pref:width MacroStepper:Frame:Width)
|
||||
(pref:get/set pref:height MacroStepper:Frame:Height)
|
||||
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
|
||||
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
|
||||
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
|
||||
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
|
||||
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
|
||||
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
|
||||
(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?)
|
||||
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
|
||||
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
|
||||
(pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
|
||||
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
|
||||
(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
|
||||
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
|
||||
|
||||
(define macro-stepper-config-base%
|
||||
(class object%
|
||||
(notify-methods width)
|
||||
(notify-methods height)
|
||||
(notify-methods macro-hiding-mode)
|
||||
(notify-methods props-percentage)
|
||||
(notify-methods show-syntax-properties?)
|
||||
(notify-methods show-hiding-panel?)
|
||||
(notify-methods identifier=?)
|
||||
(notify-methods highlight-foci?)
|
||||
(notify-methods highlight-frontier?)
|
||||
(notify-methods show-rename-steps?)
|
||||
(notify-methods suppress-warnings?)
|
||||
(notify-methods one-by-one?)
|
||||
(notify-methods extra-navigation?)
|
||||
(notify-methods debug-catch-errors?)
|
||||
(notify-methods force-letrec-transformation?)
|
||||
(super-new)))
|
||||
|
||||
(define macro-stepper-config/prefs%
|
||||
(class macro-stepper-config-base%
|
||||
(connect-to-pref width pref:width)
|
||||
(connect-to-pref height pref:height)
|
||||
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
|
||||
(connect-to-pref props-percentage pref:props-percentage)
|
||||
(connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
|
||||
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
|
||||
(connect-to-pref identifier=? pref:identifier=?)
|
||||
(connect-to-pref highlight-foci? pref:highlight-foci?)
|
||||
(connect-to-pref highlight-frontier? pref:highlight-frontier?)
|
||||
(connect-to-pref show-rename-steps? pref:show-rename-steps?)
|
||||
(connect-to-pref suppress-warnings? pref:suppress-warnings?)
|
||||
(connect-to-pref one-by-one? pref:one-by-one?)
|
||||
(connect-to-pref extra-navigation? pref:extra-navigation?)
|
||||
(connect-to-pref debug-catch-errors? pref:debug-catch-errors?)
|
||||
(connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?)
|
||||
(super-new)))
|
||||
|
||||
(define macro-stepper-config/prefs/readonly%
|
||||
(class macro-stepper-config-base%
|
||||
(connect-to-pref/readonly width pref:width)
|
||||
(connect-to-pref/readonly height pref:height)
|
||||
(connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
|
||||
(connect-to-pref/readonly props-percentage pref:props-percentage)
|
||||
(connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
|
||||
(connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
|
||||
(connect-to-pref/readonly identifier=? pref:identifier=?)
|
||||
(connect-to-pref/readonly highlight-foci? pref:highlight-foci?)
|
||||
(connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?)
|
||||
(connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?)
|
||||
(connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?)
|
||||
(connect-to-pref/readonly one-by-one? pref:one-by-one?)
|
||||
(connect-to-pref/readonly extra-navigation? pref:extra-navigation?)
|
||||
(connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
|
||||
(connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
|
||||
(super-new)))
|
||||
|
||||
)
|
||||
|
|
|
|||
669
collects/macro-debugger/view/stepper.ss
Normal file
669
collects/macro-debugger/view/stepper.ss
Normal file
|
|
@ -0,0 +1,669 @@
|
|||
|
||||
(module stepper mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"extensions.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix s: "../syntax-browser/widget.ss")
|
||||
(prefix s: "../syntax-browser/params.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"util.ss")
|
||||
(provide macro-stepper-widget%)
|
||||
|
||||
;; Struct for one-by-one stepping
|
||||
|
||||
(define-struct (prestep protostep) (foci1 e1))
|
||||
(define-struct (poststep protostep) (foci2 e2))
|
||||
|
||||
(define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
|
||||
(define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
|
||||
|
||||
;; TermRecords
|
||||
|
||||
(define-struct trec (deriv synth-deriv estx raw-steps steps definites) #f)
|
||||
|
||||
(define (new-trec deriv)
|
||||
(make-trec deriv #f #f #f #f #f))
|
||||
|
||||
;; trec:invalidate-synth! : TermRecord -> void
|
||||
;; Invalidates cached parts that depend on macro-hiding policy
|
||||
(define (trec:invalidate-synth! trec)
|
||||
(set-trec-synth-deriv! trec #f)
|
||||
(set-trec-estx! trec #f)
|
||||
(set-trec-raw-steps! trec #f)
|
||||
(set-trec-definites! trec #f)
|
||||
(trec:invalidate-steps! trec))
|
||||
|
||||
;; trec:invalidate-steps! : TermRecord -> void
|
||||
;; Invalidates cached parts that depend on reductions config
|
||||
(define (trec:invalidate-steps! trec)
|
||||
(set-trec-steps! trec #f))
|
||||
|
||||
|
||||
;; Macro Stepper
|
||||
|
||||
;; macro-stepper-widget%
|
||||
(define macro-stepper-widget%
|
||||
(class* object% ()
|
||||
(init-field parent)
|
||||
(init-field config)
|
||||
|
||||
;; Terms
|
||||
|
||||
;; terms : (Cursor-of TermRecord)
|
||||
(define terms (cursor:new null))
|
||||
|
||||
;; focused-term : -> TermRecord or #f
|
||||
(define (focused-term)
|
||||
(let ([term (cursor:next terms)])
|
||||
(when term (recache term))
|
||||
term))
|
||||
|
||||
;; focused-steps : -> (Cursor-of Step) or #f
|
||||
(define/private (focused-steps)
|
||||
(let ([term (focused-term)])
|
||||
(and term
|
||||
(cursor? (trec-steps term))
|
||||
(trec-steps term))))
|
||||
|
||||
;; alpha-table : module-identifier-mapping[identifier => identifier]
|
||||
(define alpha-table (make-module-identifier-mapping))
|
||||
|
||||
;; saved-position : number/#f
|
||||
(define saved-position #f)
|
||||
|
||||
;; add-deriv : Derivation -> void
|
||||
(define/public (add-deriv d)
|
||||
(let ([needs-display? (cursor:at-end? terms)])
|
||||
(for-each (lambda (id) (module-identifier-mapping-put! alpha-table id id))
|
||||
(extract-all-fresh-names d))
|
||||
(cursor:add-to-end! terms (list (new-trec d)))
|
||||
(trim-navigator)
|
||||
(if needs-display?
|
||||
(refresh/move)
|
||||
(update))))
|
||||
|
||||
;; remove-current-term : -> void
|
||||
(define/public (remove-current-term)
|
||||
(cursor:remove-current! terms)
|
||||
(trim-navigator)
|
||||
(refresh/move))
|
||||
|
||||
(define/public (get-config) config)
|
||||
(define/public (get-controller) sbc)
|
||||
(define/public (get-view) sbview)
|
||||
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
||||
|
||||
(define/public (reset-primary-partition)
|
||||
(send sbc reset-primary-partition)
|
||||
(update/preserve-view))
|
||||
|
||||
(define area (new vertical-panel% (parent parent)))
|
||||
(define supernavigator
|
||||
(new horizontal-panel%
|
||||
(parent area)
|
||||
(stretchable-height #f)
|
||||
(alignment '(center center))))
|
||||
(define navigator
|
||||
(new horizontal-panel%
|
||||
(parent supernavigator)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left center))))
|
||||
(define extra-navigator
|
||||
(new horizontal-panel%
|
||||
(parent supernavigator)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left center))
|
||||
(style '(deleted))))
|
||||
|
||||
(define sbview (new stepper-syntax-widget%
|
||||
(parent area)
|
||||
(macro-stepper this)))
|
||||
(define sbc (send sbview get-controller))
|
||||
(define control-pane
|
||||
(new vertical-panel% (parent area) (stretchable-height #f)))
|
||||
(define macro-hiding-prefs
|
||||
(new macro-hiding-prefs-widget%
|
||||
(parent control-pane)
|
||||
(stepper this)
|
||||
(config config)))
|
||||
|
||||
(define warnings-frame #f)
|
||||
|
||||
(send config listen-show-syntax-properties?
|
||||
(lambda (show?) (send sbview show-props show?)))
|
||||
(send config listen-show-hiding-panel?
|
||||
(lambda (show?) (show-macro-hiding-prefs show?)))
|
||||
(send sbc listen-selected-syntax
|
||||
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
|
||||
(send config listen-highlight-foci?
|
||||
(lambda (_) (update/preserve-view)))
|
||||
(send config listen-highlight-frontier?
|
||||
(lambda (_) (update/preserve-view)))
|
||||
(send config listen-show-rename-steps?
|
||||
(lambda (_) (refresh/re-reduce)))
|
||||
(send config listen-one-by-one?
|
||||
(lambda (_) (refresh/re-reduce)))
|
||||
(send config listen-force-letrec-transformation?
|
||||
(lambda (_) (refresh/resynth)))
|
||||
(send config listen-extra-navigation?
|
||||
(lambda (show?) (show-extra-navigation show?)))
|
||||
|
||||
(define nav:up
|
||||
(new button% (label "Previous term") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-up)))))
|
||||
(define nav:start
|
||||
(new button% (label "<-- Start") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-to-start)))))
|
||||
(define nav:previous
|
||||
(new button% (label "<- Step") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-previous)))))
|
||||
(define nav:next
|
||||
(new button% (label "Step ->") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-next)))))
|
||||
(define nav:end
|
||||
(new button% (label "End -->") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-to-end)))))
|
||||
(define nav:down
|
||||
(new button% (label "Next term") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-down)))))
|
||||
|
||||
(define/private (trim-navigator)
|
||||
(if (> (length (cursor->list terms)) 1)
|
||||
(send navigator change-children
|
||||
(lambda _
|
||||
(list nav:up
|
||||
nav:start
|
||||
nav:previous
|
||||
nav:next
|
||||
nav:end
|
||||
nav:down)))
|
||||
(send navigator change-children
|
||||
(lambda _
|
||||
(list nav:start
|
||||
nav:previous
|
||||
nav:next
|
||||
nav:end)))))
|
||||
|
||||
(define/public (show-macro-hiding-prefs show?)
|
||||
(send area change-children
|
||||
(lambda (children)
|
||||
(if show?
|
||||
(append (remq control-pane children) (list control-pane))
|
||||
(remq control-pane children)))))
|
||||
|
||||
(define/private (show-extra-navigation show?)
|
||||
(send supernavigator change-children
|
||||
(lambda (children)
|
||||
(if show?
|
||||
(list navigator extra-navigator)
|
||||
(list navigator)))))
|
||||
|
||||
;; Navigate
|
||||
|
||||
(define/private (navigate-to-start)
|
||||
(cursor:move-to-start (focused-steps))
|
||||
(update/save-position))
|
||||
(define/private (navigate-to-end)
|
||||
(cursor:move-to-end (focused-steps))
|
||||
(update/save-position))
|
||||
(define/private (navigate-previous)
|
||||
(cursor:move-prev (focused-steps))
|
||||
(update/save-position))
|
||||
(define/private (navigate-next)
|
||||
(cursor:move-next (focused-steps))
|
||||
(update/save-position))
|
||||
|
||||
(define/private (navigate-up)
|
||||
(cursor:move-prev terms)
|
||||
(refresh/move))
|
||||
(define/private (navigate-down)
|
||||
(cursor:move-next terms)
|
||||
(refresh/move))
|
||||
|
||||
;; insert-step-separator : string -> void
|
||||
(define/private (insert-step-separator text)
|
||||
(send sbview add-text "\n ")
|
||||
(send sbview add-text
|
||||
(make-object image-snip%
|
||||
(build-path (collection-path "icons")
|
||||
"red-arrow.bmp")))
|
||||
(send sbview add-text " ")
|
||||
(send sbview add-text text)
|
||||
(send sbview add-text "\n\n"))
|
||||
|
||||
;; insert-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"))
|
||||
|
||||
;; update/preserve-view : -> void
|
||||
(define/public (update/preserve-view)
|
||||
(define text (send sbview get-text))
|
||||
(define start-box (box 0))
|
||||
(define end-box (box 0))
|
||||
(send text get-visible-position-range start-box end-box)
|
||||
(update)
|
||||
(send text scroll-to-position (unbox start-box) #f (unbox end-box)))
|
||||
|
||||
;; update:show-prefix : -> void
|
||||
(define/private (update:show-prefix)
|
||||
;; Show the final terms from the cached synth'd derivs
|
||||
(for-each (lambda (trec)
|
||||
(recache trec)
|
||||
(let ([e2 (trec-estx trec)]
|
||||
[definites
|
||||
(if (pair? (trec-definites trec))
|
||||
(trec-definites trec)
|
||||
null)])
|
||||
(if e2
|
||||
(send sbview add-syntax e2
|
||||
#:alpha-table alpha-table
|
||||
#:definites definites)
|
||||
(send sbview add-text "Error\n"))))
|
||||
(cursor:prefix->list terms)))
|
||||
|
||||
;; update:show-current-step : -> void
|
||||
(define/private (update:show-current-step)
|
||||
(define steps (focused-steps))
|
||||
(when (focused-term)
|
||||
(when steps
|
||||
(let ([step (cursor:next steps)])
|
||||
(cond [(step? step)
|
||||
(update:show-step step)]
|
||||
[(mono? step)
|
||||
(update:show-mono step)]
|
||||
[(misstep? step)
|
||||
(update:show-misstep step)]
|
||||
[(prestep? step)
|
||||
(update:show-prestep step)]
|
||||
[(poststep? step)
|
||||
(update:show-poststep step)]
|
||||
[(not step)
|
||||
(update:show-final (focused-term))])))
|
||||
(unless steps
|
||||
(send sbview add-text
|
||||
"Internal error computing reductions. Original term:\n")
|
||||
(send sbview add-syntax
|
||||
(lift/deriv-e1 (trec-deriv (focused-term)))))))
|
||||
|
||||
;; update:show-lctx : Step -> void
|
||||
(define/private (update:show-lctx step)
|
||||
(define lctx (protostep-lctx step))
|
||||
(when (pair? lctx)
|
||||
(send sbview add-text "\n")
|
||||
(for-each (lambda (bf)
|
||||
(send sbview add-text
|
||||
"while executing macro transformer in:\n")
|
||||
(insert-syntax/redex (bigframe-term bf)
|
||||
(bigframe-foci bf)
|
||||
(protostep-definites step)
|
||||
(protostep-frontier step)))
|
||||
(reverse lctx))))
|
||||
|
||||
;; update:separator : Step -> void
|
||||
(define/private (update:separator step)
|
||||
(if (not (mono? step))
|
||||
(insert-step-separator (step-type->string (protostep-type step)))
|
||||
(insert-as-separator (step-type->string (protostep-type step)))))
|
||||
|
||||
;; update:separator/small : Step -> void
|
||||
(define/private (update:separator/small step)
|
||||
(insert-step-separator/small
|
||||
(step-type->string (protostep-type step))))
|
||||
|
||||
;; update:show-step : Step -> void
|
||||
(define/private (update:show-step step)
|
||||
(insert-syntax/redex (step-term1 step)
|
||||
(step-foci1 step)
|
||||
(protostep-definites step)
|
||||
(protostep-frontier step))
|
||||
(update:separator step)
|
||||
(insert-syntax/contractum (step-term2 step)
|
||||
(step-foci2 step)
|
||||
(protostep-definites step)
|
||||
(protostep-frontier step))
|
||||
(update:show-lctx step))
|
||||
|
||||
;; update:show-mono : Step -> void
|
||||
(define/private (update:show-mono step)
|
||||
(update:separator step)
|
||||
(insert-syntax/redex (mono-term1 step)
|
||||
null
|
||||
(protostep-definites step)
|
||||
(protostep-frontier step))
|
||||
(update:show-lctx step))
|
||||
|
||||
;; update:show-prestep : Step -> void
|
||||
(define/private (update:show-prestep step)
|
||||
(update:separator/small step)
|
||||
(insert-syntax/redex (prestep-term1 step)
|
||||
(prestep-foci1 step)
|
||||
(protostep-definites step)
|
||||
(protostep-frontier step))
|
||||
(update:show-lctx step))
|
||||
|
||||
;; update:show-poststep : Step -> void
|
||||
(define/private (update:show-poststep step)
|
||||
(update:separator/small step)
|
||||
(insert-syntax/contractum (poststep-term2 step)
|
||||
(poststep-foci2 step)
|
||||
(protostep-definites step)
|
||||
(protostep-frontier step))
|
||||
(update:show-lctx step))
|
||||
|
||||
;; update:show-misstep : Step -> void
|
||||
(define/private (update:show-misstep step)
|
||||
(insert-syntax/redex (misstep-term1 step)
|
||||
(misstep-foci1 step)
|
||||
(protostep-definites step)
|
||||
(protostep-frontier step))
|
||||
(update:separator step)
|
||||
(send sbview add-text (exn-message (misstep-exn step)))
|
||||
(send sbview add-text "\n")
|
||||
(when (exn:fail:syntax? (misstep-exn step))
|
||||
(for-each (lambda (e) (send sbview add-syntax e
|
||||
#:alpha-table alpha-table
|
||||
#:definites (protostep-definites step)))
|
||||
(exn:fail:syntax-exprs (misstep-exn step))))
|
||||
(update:show-lctx step))
|
||||
|
||||
;; update:show-final : TermRecord -> void
|
||||
(define/private (update:show-final trec)
|
||||
(define result (trec-estx trec))
|
||||
(when result
|
||||
(send sbview add-text "Expansion finished\n")
|
||||
(send sbview add-syntax result
|
||||
#:alpha-table alpha-table
|
||||
#:definites (let ([definites (trec-definites trec)])
|
||||
(if (pair? definites) definites null))))
|
||||
(unless result
|
||||
(send sbview add-text "Error\n")))
|
||||
|
||||
;; update:show-suffix : -> void
|
||||
(define/private (update:show-suffix)
|
||||
(let ([suffix0 (cursor:suffix->list terms)])
|
||||
(when (pair? suffix0)
|
||||
(for-each (lambda (trec)
|
||||
(send sbview add-syntax
|
||||
(lift/deriv-e1 (trec-deriv trec))
|
||||
#:alpha-table alpha-table))
|
||||
(cdr suffix0)))))
|
||||
|
||||
;; update/save-position : -> void
|
||||
(define/private (update/save-position)
|
||||
(save-position)
|
||||
(update))
|
||||
|
||||
;; update : -> void
|
||||
;; Updates the terms in the syntax browser to the current step
|
||||
(define/private (update)
|
||||
(define text (send sbview get-text))
|
||||
(define position-of-interest 0)
|
||||
(define multiple-terms? (> (length (cursor->list terms)) 1))
|
||||
(send text begin-edit-sequence)
|
||||
(send sbview erase-all)
|
||||
|
||||
(update:show-prefix)
|
||||
(when multiple-terms? (send sbview add-separator))
|
||||
(set! position-of-interest (send text last-position))
|
||||
(update:show-current-step)
|
||||
(when multiple-terms? (send sbview add-separator))
|
||||
(update:show-suffix)
|
||||
(send text end-edit-sequence)
|
||||
(send text scroll-to-position
|
||||
position-of-interest
|
||||
#f
|
||||
(send text last-position)
|
||||
'start)
|
||||
(enable/disable-buttons))
|
||||
|
||||
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
|
||||
(define/private (insert-syntax/color stx foci definites frontier hi-color)
|
||||
(send sbview add-syntax stx
|
||||
#:definites definites
|
||||
#:alpha-table alpha-table
|
||||
#:hi-color hi-color
|
||||
#:hi-stxs (if (send config get-highlight-foci?) foci null)
|
||||
#:hi2-color "WhiteSmoke"
|
||||
#:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
|
||||
|
||||
;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
|
||||
(define/private (insert-syntax/redex stx foci definites frontier)
|
||||
(insert-syntax/color stx foci definites frontier "MistyRose"))
|
||||
|
||||
;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
|
||||
(define/private (insert-syntax/contractum stx foci definites frontier)
|
||||
(insert-syntax/color stx foci definites frontier "LightCyan"))
|
||||
|
||||
;; enable/disable-buttons : -> void
|
||||
(define/private (enable/disable-buttons)
|
||||
(define steps (focused-steps))
|
||||
(send nav:start enable (and steps (cursor:has-prev? steps)))
|
||||
(send nav:previous enable (and steps (cursor:has-prev? steps)))
|
||||
(send nav:next enable (and steps (cursor:has-next? steps)))
|
||||
(send nav:end enable (and steps (cursor:has-next? steps)))
|
||||
(send nav:up enable (cursor:has-prev? terms))
|
||||
(send nav:down enable (cursor:has-next? terms)))
|
||||
|
||||
;; --
|
||||
|
||||
;; refresh/resynth : -> void
|
||||
;; Macro hiding policy has changed; invalidate cached parts of trec
|
||||
(define/public (refresh/resynth)
|
||||
(for-each trec:invalidate-synth! (cursor->list terms))
|
||||
(refresh))
|
||||
|
||||
;; refresh/re-reduce : -> void
|
||||
;; Reduction config has changed; invalidate cached parts of trec
|
||||
(define/private (refresh/re-reduce)
|
||||
(for-each trec:invalidate-steps! (cursor->list terms))
|
||||
(refresh))
|
||||
|
||||
;; refresh/move : -> void
|
||||
;; Moving between terms; clear the saved position
|
||||
(define/private (refresh/move)
|
||||
(clear-saved-position)
|
||||
(refresh))
|
||||
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(restore-position)
|
||||
(update))
|
||||
|
||||
;; recache : TermRecord -> void
|
||||
(define/private (recache trec)
|
||||
(unless (trec-synth-deriv trec)
|
||||
(with-handlers ([(lambda (e) #t)
|
||||
(lambda (e)
|
||||
(handle-recache-error e 'macro-hiding)
|
||||
(set-trec-synth-deriv! trec 'error)
|
||||
(set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))])
|
||||
(let-values ([(synth-deriv estx) (synthesize (trec-deriv trec))])
|
||||
(set-trec-synth-deriv! trec synth-deriv)
|
||||
(set-trec-estx! trec estx))))
|
||||
(unless (trec-raw-steps trec)
|
||||
(with-handlers ([(lambda (e) #t)
|
||||
(lambda (e)
|
||||
(handle-recache-error e 'reductions)
|
||||
(set-trec-raw-steps! trec 'error)
|
||||
(set-trec-definites! trec 'error))])
|
||||
(let-values ([(steps definites)
|
||||
(reductions+definites
|
||||
(or (trec-synth-deriv trec) (trec-deriv trec)))])
|
||||
(set-trec-raw-steps! trec steps)
|
||||
(set-trec-definites! trec definites))))
|
||||
(unless (trec-steps trec)
|
||||
(with-handlers ([(lambda (e) #t)
|
||||
(lambda (e)
|
||||
(handle-recache-error e 'special-reductions)
|
||||
(set-trec-steps! trec 'error))])
|
||||
(set-trec-steps!
|
||||
trec
|
||||
(let ([raw-steps (trec-raw-steps trec)])
|
||||
(if (eq? raw-steps 'error)
|
||||
'error
|
||||
(let ([filtered-steps
|
||||
(if (send config get-show-rename-steps?)
|
||||
raw-steps
|
||||
(filter (lambda (x) (not (rename-step? x))) raw-steps))])
|
||||
(cursor:new
|
||||
(if (send config get-one-by-one?)
|
||||
(reduce:one-by-one filtered-steps)
|
||||
filtered-steps)))))))))
|
||||
|
||||
;; delayed-recache-errors : (list-of (cons exn string))
|
||||
(define delayed-recache-errors null)
|
||||
|
||||
;; handle-recache-error : exception string -> void
|
||||
(define/private (handle-recache-error exn part)
|
||||
(if (send config get-debug-catch-errors?)
|
||||
(begin
|
||||
(set! delayed-recache-errors
|
||||
(cons (cons exn part) delayed-recache-errors))
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(when (pair? delayed-recache-errors)
|
||||
(message-box
|
||||
"Error"
|
||||
(string-append
|
||||
"Internal errors in macro stepper:\n"
|
||||
(if (memq 'macro-hiding (map cdr delayed-recache-errors))
|
||||
(string-append
|
||||
"Macro hiding failed on one or more terms. "
|
||||
"The macro stepper is showing the terms "
|
||||
"with macro hiding disabled.\n")
|
||||
"")
|
||||
(if (memq 'reductions (map cdr delayed-recache-errors))
|
||||
(string-append
|
||||
"The macro stepper failed to compute the reduction sequence "
|
||||
"for one or more terms.\n")
|
||||
"")))
|
||||
(set! delayed-recache-errors null)))))
|
||||
(raise exn)))
|
||||
|
||||
;; update-saved-position : num -> void
|
||||
(define/private (update-saved-position pos)
|
||||
(when pos (set! saved-position pos)))
|
||||
|
||||
;; clear-saved-position : -> void
|
||||
(define/private (clear-saved-position)
|
||||
(set! saved-position #f))
|
||||
|
||||
;; save-position : -> void
|
||||
(define/private (save-position)
|
||||
(when (cursor? (focused-steps))
|
||||
(let ([step (cursor:next (focused-steps))])
|
||||
(cond [(not step)
|
||||
;; At end; go to the end when restored
|
||||
(update-saved-position +inf.0)]
|
||||
[(protostep? step)
|
||||
(update-saved-position
|
||||
(extract-protostep-seq step))]))))
|
||||
|
||||
;; restore-position : number -> void
|
||||
(define/private (restore-position)
|
||||
(define steps (focused-steps))
|
||||
(define (advance)
|
||||
(let ([step (cursor:next steps)])
|
||||
(cond [(not step)
|
||||
;; At end; stop
|
||||
(void)]
|
||||
[(protostep? step)
|
||||
(let ([step-pos (extract-protostep-seq step)])
|
||||
(cond [(not step-pos)
|
||||
(cursor:move-next steps)
|
||||
(advance)]
|
||||
[(< step-pos saved-position)
|
||||
(cursor:move-next steps)
|
||||
(advance)]
|
||||
[else (void)]))])))
|
||||
(when saved-position
|
||||
(when steps
|
||||
(advance))))
|
||||
|
||||
(define/private (extract-protostep-seq step)
|
||||
(match (protostep-deriv step)
|
||||
[(AnyQ mrule (_ _ (AnyQ transformation (_ _ _ _ _ _ seq)) _))
|
||||
seq]
|
||||
[else #f]))
|
||||
|
||||
;; synthesize : Derivation -> Derivation Syntax
|
||||
(define/private (synthesize deriv)
|
||||
(let ([show-macro? (get-show-macro?)])
|
||||
(if show-macro?
|
||||
(parameterize ((current-hiding-warning-handler
|
||||
(lambda (tag message)
|
||||
(unless (send config get-suppress-warnings?)
|
||||
(unless warnings-frame
|
||||
(set! warnings-frame (new warnings-frame%)))
|
||||
(send warnings-frame add-warning tag message)
|
||||
(send warnings-frame show #t))))
|
||||
(force-letrec-transformation
|
||||
(send config get-force-letrec-transformation?)))
|
||||
(hide/policy deriv show-macro?))
|
||||
(values deriv (lift/deriv-e2 deriv)))))
|
||||
|
||||
(define/private (reduce:one-by-one rs)
|
||||
(let loop ([rs rs])
|
||||
(match rs
|
||||
[(cons (struct step (d l t c df fr redex contractum e1 e2)) rs)
|
||||
(list* (make-prestep d l "Find redex" c df fr redex e1)
|
||||
(make-poststep d l t c df fr contractum e2)
|
||||
(loop rs))]
|
||||
[(cons (struct misstep (d l t c df fr redex e1 exn)) rs)
|
||||
(list* (make-prestep d l "Find redex" c df fr redex e1)
|
||||
(make-misstep d l t c df fr redex e1 exn)
|
||||
(loop rs))]
|
||||
['()
|
||||
null])))
|
||||
|
||||
(define/private (foci x) (if (list? x) x (list x)))
|
||||
|
||||
;; Hiding policy
|
||||
|
||||
(define/private (get-show-macro?)
|
||||
(send macro-hiding-prefs get-policy))
|
||||
|
||||
;; --
|
||||
|
||||
(define/public (shutdown)
|
||||
(when warnings-frame (send warnings-frame show #f)))
|
||||
|
||||
;; Initialization
|
||||
|
||||
(super-new)
|
||||
(send sbview show-props (send config get-show-syntax-properties?))
|
||||
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
|
||||
(show-extra-navigation (send config get-extra-navigation?))
|
||||
(refresh/move)
|
||||
))
|
||||
|
||||
)
|
||||
|
|
@ -1,26 +1,35 @@
|
|||
|
||||
(module view mzscheme
|
||||
(require (lib "unit.ss")
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
"interfaces.ss"
|
||||
"gui.ss")
|
||||
"frame.ss"
|
||||
"prefs.ss"
|
||||
"../model/trace.ss")
|
||||
(provide (all-defined))
|
||||
|
||||
(define view-base@
|
||||
(unit
|
||||
(import)
|
||||
(export view-base^)
|
||||
(define macro-stepper-frame%
|
||||
(macro-stepper-frame-mixin
|
||||
(frame:standard-menus-mixin
|
||||
(frame:basic-mixin frame%))))
|
||||
|
||||
;; Main entry points
|
||||
|
||||
(define (make-macro-stepper)
|
||||
(let ([f (new macro-stepper-frame%
|
||||
(config (new macro-stepper-config/prefs%)))])
|
||||
(send f show #t)
|
||||
(send f get-widget)))
|
||||
|
||||
(define base-frame%
|
||||
(frame:standard-menus-mixin (frame:basic-mixin frame%)))))
|
||||
|
||||
(define-values/invoke-unit
|
||||
(compound-unit
|
||||
(import)
|
||||
(link [((BASE : view-base^)) view-base@]
|
||||
[((STEPPER : view^)) pre-stepper@ BASE])
|
||||
(export STEPPER))
|
||||
(import)
|
||||
(export view^))
|
||||
(define (go stx)
|
||||
(let ([stepper (make-macro-stepper)])
|
||||
(send stepper add-deriv (trace stx))))
|
||||
|
||||
(define (go/deriv deriv)
|
||||
(let* ([f (new macro-stepper-frame%)]
|
||||
[w (send f get-widget)])
|
||||
(send w add-deriv deriv)
|
||||
(send f show #t)
|
||||
w))
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user