suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Reorganized syntax-browser

Browse Source 
svn: r4500

original commit: 2954ed58441dd1cdf4492a9bc2362c41fc6288d2
This commit is contained in:
Ryan Culpepper 2006-10-06 02:26:04 +00:00
parent 5f1b8d4da6
commit 9599b2253b
13 changed files with 698 additions and 601 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/macro-debugger/syntax-browser.ss
View File

@ -1,8 +1,8 @@
(module syntax-browser mzscheme (module syntax-browser mzscheme
(require "syntax-browser/syntax-browser.ss" (require "syntax-browser/browser.ss")
"syntax-browser/syntax-snip.ss")
(provide browse-syntax (provide browse-syntax
browse-syntaxes browse-syntaxes
syntax-snip)) make-syntax-browser
syntax-snip)
)

8
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -2,8 +2,7 @@
(module controller mzscheme (module controller mzscheme
(require (lib "class.ss") (require (lib "class.ss")
"interfaces.ss" "interfaces.ss"
"partition.ss" "partition.ss")
"properties.ss")
(provide syntax-controller%) (provide syntax-controller%)
@ -17,8 +16,7 @@
(define selection-listeners null) (define selection-listeners null)
(define selected-syntax #f) (define selected-syntax #f)
(define identifier=?-listeners null) (define identifier=?-listeners null)
(init-field (properties-controller (init-field (properties-controller #f))
(new independent-properties-controller% (controller this))))
;; syntax-controller<%> Methods ;; syntax-controller<%> Methods
@ -31,6 +29,8 @@
(define/public (get-selected-syntax) selected-syntax) (define/public (get-selected-syntax) selected-syntax)
(define/public (get-properties-controller) properties-controller) (define/public (get-properties-controller) properties-controller)
(define/public (set-properties-controller pc)
(set! properties-controller pc))
(define/public (add-view-colorer c) (define/public (add-view-colorer c)
(set! colorers (cons c colorers)) (set! colorers (cons c colorers))

11
collects/macro-debugger/syntax-browser/embed.ss Normal file
View File

@ -0,0 +1,11 @@
(module embed mzscheme
(require "interfaces.ss"
"implementation.ss"
"params.ss"
"partition.ss")
(provide (all-from "interfaces.ss")
(all-from "implementation.ss")
(all-from "params.ss")
identifier=-choices))

51
collects/macro-debugger/syntax-browser/frame.ss Normal file
View File

@ -0,0 +1,51 @@
(module frame mzscheme
(require (lib "class.ss")
(lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
"interfaces.ss")
(provide frame@)
(define frame@
(unit/sig browser^
(import prefs^
widget^)
;; 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)
(preferences:save)
(inner (void) on-close))
))))
)

60
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,8 +1,66 @@
(module interfaces mzscheme (module interfaces mzscheme
(require (lib "class.ss")) (require (lib "class.ss")
(lib "unitsig.ss"))
(provide (all-defined)) (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-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%
;; syntax-widget/controls%
syntax-widget/controls%))
(define-signature implementation^
([unit widget : widget^]
[unit snip : snip^]))
;; Class Interfaces
;; syntax-controller<%> ;; syntax-controller<%>
;; A syntax-controller coordinates state shared by many different syntax views. ;; A syntax-controller coordinates state shared by many different syntax views.
;; Syntax views can share: ;; Syntax views can share:

123
collects/macro-debugger/syntax-browser/keymap.ss Normal file
View File

@ -0,0 +1,123 @@
(module keymap mzscheme
(require (lib "class.ss")
(lib "unitsig.ss")
(lib "mred.ss" "mred")
"interfaces.ss"
"partition.ss")
(provide keymap@
context-menu@)
(define keymap@
(unit/sig keymap^
(import)
(define syntax-keymap%
(class keymap%
(init editor)
(init-field context-menu)
(inherit add-function
map-function
chain-to-keymap)
(super-new)
;; Initialization
(map-function "rightbutton" "popup-context-window")
(add-function "popup-context-window"
(lambda (editor event)
(do-popup-context-window editor event)))
;; Attach to editor
(chain-to-keymap (send editor get-keymap) #t)
(send editor set-keymap this)
(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))))))
(define context-menu@
(unit/sig context-menu^
(import snip^)
(define context-menu%
(class popup-menu%
(init-field controller)
(super-new)
(define/public (add-edit-items)
(new menu-item% (label "Copy") (parent this)
(callback (lambda (i e)
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
"")
(send e get-time-stamp)))))
(new menu-item% (label "Copy syntax") (parent this)
(callback (lambda (i e)
(define stx (send controller get-selected-syntax))
(define t (new text%))
(send t insert
(new syntax-snip%
(syntax stx)
#;(controller controller)))
(send t select-all)
(send t copy))))
(void))
(define/public (after-edit-items)
(void))
(define/public (add-selection-items)
(new menu-item%
(label "Clear selection")
(parent this)
(callback (lambda _ (send controller select-syntax #f))))
(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 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 (add-separator)
(new separator-menu-item% (parent this)))
;; Initialization
(add-edit-items)
(after-edit-items)
(add-separator)
(add-selection-items)
(after-selection-items)
(add-separator)
(add-partition-items)
(after-partition-items)
))))
)

29
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -1,10 +1,9 @@
(module prefs mzscheme (module prefs mzscheme
(require (lib "framework.ss" "framework")) (require (lib "unitsig.ss")
(provide (all-defined)) (lib "framework.ss" "framework")
"interfaces.ss")
(define current-syntax-font-size (make-parameter #f #;16)) (provide prefs@)
(define current-default-columns (make-parameter 60))
(define-syntax pref:get/set (define-syntax pref:get/set
(syntax-rules () (syntax-rules ()
@ -14,14 +13,18 @@
[() (preferences:get 'prop)] [() (preferences:get 'prop)]
[(newval) (preferences:set 'prop newval)]))])) [(newval) (preferences:set 'prop newval)]))]))
(preferences:set-default 'SyntaxBrowser:Width 700 number?) (define prefs@
(preferences:set-default 'SyntaxBrowser:Height 600 number?) (unit/sig prefs^
(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) (import)
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
(pref:get/set pref:width SyntaxBrowser:Width) (preferences:set-default 'SyntaxBrowser:Width 700 number?)
(pref:get/set pref:height SyntaxBrowser:Height) (preferences:set-default 'SyntaxBrowser:Height 600 number?)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) (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)))
) )

2
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -9,7 +9,7 @@
"pretty-range.ss" "pretty-range.ss"
"pretty-helper.ss" "pretty-helper.ss"
"interfaces.ss" "interfaces.ss"
"prefs.ss") "params.ss")
(provide syntax-pp% (provide syntax-pp%
(struct range (obj start end))) (struct range (obj start end)))

30
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -1,36 +1,10 @@
(module properties mzscheme (module properties mzscheme
(require "prefs.ss" (require "interfaces.ss"
"interfaces.ss"
"partition.ss"
"util.ss" "util.ss"
(lib "class.ss") (lib "class.ss")
(lib "mred.ss" "mred")) (lib "mred.ss" "mred"))
(provide properties-view% (provide properties-view%)
independent-properties-controller%)
;; independent-properties-controller%
(define independent-properties-controller%
(class* object% (syntax-properties-controller<%>)
(init-field controller)
;; 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 (is-shown?)
(send parent is-shown?))
(super-new)))
;; properties-view% ;; properties-view%
(define properties-view% (define properties-view%

482
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -1,237 +1,222 @@
(module syntax-snip mzscheme (module syntax-snip mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "match.ss") (lib "unitsig.ss")
(lib "list.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "string.ss")
"interfaces.ss" "interfaces.ss"
"partition.ss" "controller.ss"
"typesetter.ss" "properties.ss"
"widget.ss" "typesetter.ss")
"syntax-browser.ss") (provide snip@
(provide syntax-snip snip-context-menu-extension@)
snip-class
syntax-value-snip%
syntax-snip%)
;; syntax-snip : syntax -> snip (define snip@
(define (syntax-snip stx) (unit/sig snip^
(new syntax-snip% (syntax stx))) (import prefs^
keymap^
context-menu^
snipclass^)
(define current-syntax-controller (make-parameter #f)) ;; syntax-snip : syntax -> snip
(define (syntax-snip stx)
(new syntax-snip% (syntax stx)))
(define (the-syntax-controller) (define *syntax-controller* #f)
(let ([controller (current-syntax-controller)])
(or controller
(let ([controller (new syntax-controller%)])
(current-syntax-controller controller)
controller))))
;; syntax-value-snip% (define (the-syntax-controller)
(define syntax-value-snip% (let ([controller *syntax-controller*])
(class* editor-snip% (readable-snip<%>) (or controller
(init-field ((stx syntax))) (let* ([controller (new syntax-controller%)]
(init-field controller) [props (new independent-properties-controller% (controller controller))])
(inherit set-margin (send controller set-properties-controller props)
set-inset) (set! *syntax-controller* controller)
controller))))
(define -outer (new text:standard-style-list%)) ;; syntax-value-snip%
(super-new (editor -outer) (with-border? #f)) (define syntax-value-snip%
(set-margin 0 0 0 0) (class* editor-snip% (readable-snip<%>)
(set-inset 2 2 2 2) (init-field ((stx syntax)))
(refresh) (init-field controller)
(inherit set-margin
set-inset)
(define/private (refresh) (define -outer (new text:standard-style-list%))
(send -outer begin-edit-sequence) (super-new (editor -outer) (with-border? #f))
(send -outer erase) (set-margin 0 0 0 0)
(new typesetter-for-text% (set-inset 2 2 2 2)
(syntax stx) (send -outer change-style (make-object style-delta% 'change-alignment 'top))
(controller controller) (new syntax-keymap%
(text -outer)) (editor -outer)
(send -outer lock #t) (context-menu (new context-menu% (snip this))))
(send -outer end-edit-sequence) (refresh)
(send -outer hide-caret #t))
(define/private (show-props) (define/public (get-controller) controller)
(send (send controller get-properties-controller)
show #t))
(define/private outer:insert (define/private (refresh)
(case-lambda (send -outer begin-edit-sequence)
[(obj) (send -outer erase)
(outer:insert obj style:normal)] (new typesetter-for-text%
[(text style) (syntax stx)
(outer:insert text style #f)] (controller controller)
[(text style clickback) (text -outer))
(let ([start (send -outer last-position)]) (send -outer lock #t)
(send -outer insert text) (send -outer end-edit-sequence)
(let ([end (send -outer last-position)]) (send -outer hide-caret #t))
(send -outer change-style style start end #f)
(when clickback
(send -outer set-clickback start end clickback))))]))
;; BEGIN COPIED from widget.ss (define/public (show-props)
;; WITH MODIFICATIONS (send (send controller get-properties-controller)
;; Set up keymap show #t))
(let ([keymap (send -outer get-keymap)])
(send keymap map-function "rightbutton" "popup-context-window")
(send keymap add-function "popup-context-window"
(lambda (editor event)
(do-popup-context-window editor event))))
(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))
(define context-menu
(let ([context-menu (new popup-menu%)])
(new menu-item% (label "Copy") (parent context-menu)
(callback (lambda (i e)
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
"")
(send e get-time-stamp)))))
;; ADDED
(new menu-item% (label "Copy syntax") (parent context-menu)
(callback (lambda (i e)
(define stx (send controller get-selected-syntax))
(define t (new text%))
(send t insert
(new syntax-snip%
(syntax stx)
(controller controller)))
(send t select-all)
(send t copy))))
;; FIXME: Add option for "formatted" copy/paste?
(new menu-item%
(label "Clear selection")
(parent context-menu)
(callback (lambda _ (send controller select-syntax #f))))
(new separator-menu-item% (parent context-menu))
;; properties (MODIFIED)
(new menu-item%
(label "Show syntax properties")
(parent context-menu)
(callback (lambda _ (show-props))))
;; syntax browser (ADDED)
(new menu-item%
(label "Show in browser frame")
(parent context-menu)
(callback (lambda _ (browse-syntax stx))))
;; primary selection
(let ([secondary (new menu% (label "identifier=?") (parent context-menu))])
(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))))
context-menu))
;; END COPIED
;; snip% Methods (define/private outer:insert
(define/override (copy) (case-lambda
(new syntax-value-snip% (controller controller) (syntax stx))) [(obj)
(outer:insert obj style:normal)]
[(text style)
(outer:insert text style #f)]
[(text style clickback)
(let ([start (send -outer last-position)])
(send -outer insert text)
(let ([end (send -outer last-position)])
(send -outer change-style style start end #f)
(when clickback
(send -outer set-clickback start end clickback))))]))
(define/public (read-special src line col pos) ;; snip% Methods
(datum->syntax-object #f (define/override (copy)
`(,#'quote-syntax ,stx) (new syntax-value-snip% (controller controller) (syntax stx)))
(list src line col pos 1)))
(define/public (read-special src line col pos)
#;(datum->syntax-object #f
`(,#'quote-syntax ,stx)
(list src line col pos 1))
#`(force '#,(delay stx)))
))
(define syntax-snip%
(class* editor-snip% (readable-snip<%>)
(init-field ((stx syntax)))
(init-field (controller (the-syntax-controller)))
(inherit set-margin
set-inset
set-snipclass
set-tight-text-fit
show-border)
(define -outer (new text%))
(super-new (editor -outer) (with-border? #f))
(set-margin 2 0 0 0)
(set-inset 3 0 0 0)
(set-snipclass snip-class)
(send -outer select-all)
(send -outer change-style (make-object style-delta% 'change-alignment 'top)
0
(send -outer last-position))
(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/private (hide-me)
(send* -outer
(begin-edit-sequence)
(lock #f)
(erase))
(set-tight-text-fit #t)
(show-border #f)
(outer:insert (show-icon) style:hyper (lambda _ (show-me)))
(outer:insert the-summary)
(send* -outer
(lock #t)
(end-edit-sequence)))
(define/private (show-me)
(send* -outer
(begin-edit-sequence)
(lock #f)
(erase))
(set-tight-text-fit #f)
(show-border #t)
(outer:insert (hide-icon) style:hyper (lambda _ (hide-me)))
(outer:insert " ")
(outer:insert the-syntax-snip)
(send* -outer
(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% (controller controller) (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))
(hide-me)
(send -outer hide-caret #t)
(send -outer lock #t)
))
;; independent-properties-controller%
(define independent-properties-controller%
(class* object% (syntax-properties-controller<%>)
(init-field controller)
;; 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 (is-shown?)
(send parent is-shown?))
(super-new)))
)) ))
(define syntax-snip% (define snip-context-menu-extension@
(class* editor-snip% (readable-snip<%>) (unit/sig context-menu^
(init-field ((stx syntax))) (import (pre : context-menu^))
(init-field (controller (the-syntax-controller)))
(inherit set-margin
set-inset
set-snipclass
set-tight-text-fit
show-border)
(define -outer (new text%)) (define context-menu%
(super-new (editor -outer) (with-border? #f)) (class pre:context-menu%
(set-margin 2 0 0 0) (init-field snip)
(set-inset 3 0 0 0)
(set-snipclass snip-class)
(define the-syntax-snip (define/override (after-selection-items)
(new syntax-value-snip% (syntax stx) (controller controller))) (super after-selection-items)
(define the-summary (new menu-item% (label "Show syntax properties")
(let ([line (syntax-line stx)] (parent this)
[col (syntax-column stx)]) (callback (lambda _ (send snip show-props))))
(if (and line col) (void))
(format "#<syntax:~s:~s>" line col)
"#<syntax>")))
(define/private (hide-me) (super-new (controller (send snip get-controller)))))))
(send* -outer
(begin-edit-sequence)
(lock #f)
(erase))
(set-tight-text-fit #t)
(show-border #f)
(outer:insert (show-icon) style:hyper (lambda _ (show-me)))
(outer:insert the-summary)
(send* -outer
(lock #t)
(end-edit-sequence)))
(define/private (show-me)
(send* -outer
(begin-edit-sequence)
(lock #f)
(erase))
(set-tight-text-fit #f)
(show-border #t)
(outer:insert (hide-icon) style:hyper (lambda _ (hide-me)))
(outer:insert " ")
(outer:insert the-syntax-snip)
(send* -outer
(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% (controller controller) (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))
(hide-me)
(send -outer hide-caret #t)
(send -outer lock #t)
))
(define style:normal (make-object style-delta% 'change-normal)) (define style:normal (make-object style-delta% 'change-normal))
(define style:hyper (define style:hyper
@ -251,22 +236,6 @@
(make-object image-snip% (make-object image-snip%
(build-path (collection-path "icons") "turn-down.png"))) (build-path (collection-path "icons") "turn-down.png")))
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
(define syntax-snipclass%
(class snip-class%
(define/override (read stream)
(let ([str (send stream get-bytes)])
(make-object syntax-snip%
(unmarshall-syntax (read-from-string (bytes->string/utf-8 str))))))
(super-instantiate ())))
(define snip-class (make-object syntax-snipclass%))
(send snip-class set-version 2)
(send snip-class set-classname
(format "~s" '(lib "syntax-snip.ss" "macro-debugger" "syntax-browser")))
(send (get-the-snip-class-list) add snip-class)
;; marshall-syntax : syntax -> printable ;; marshall-syntax : syntax -> printable
(define (marshall-syntax stx) (define (marshall-syntax stx)
(unless (syntax? stx) (unless (syntax? stx)
@ -294,64 +263,11 @@
`(pair ,(cons (marshall-object (car obj)) `(pair ,(cons (marshall-object (car obj))
(marshall-object (cdr obj))))] (marshall-object (cdr obj))))]
[(or (symbol? obj) [(or (symbol? obj)
(char? obj) (char? obj)
(number? obj) (number? obj)
(string? obj) (string? obj)
(boolean? obj) (boolean? obj)
(null? obj)) (null? obj))
`(other ,obj)] `(other ,obj)]
[else (string->symbol (format "unknown-object: ~s" obj))])) [else (string->symbol (format "unknown-object: ~s" obj))]))
)
(define (unmarshall-syntax stx)
(match stx
[`(syntax
(source ,src)
(source-module ,source-module) ;; marshalling
(position ,pos)
(line ,line)
(column ,col)
(span ,span)
(original? ,original?)
(properties ,@(properties ...))
(contents ,contents))
(foldl
add-properties
(datum->syntax-object
#'here ;; ack
(unmarshall-object contents)
(list (unmarshall-object src)
line
col
pos
span))
properties)]
[else #'unknown-syntax-object]))
;; add-properties : syntax any -> syntax
(define (add-properties prop-spec stx)
(match prop-spec
[`(,(and sym (? symbol?))
,prop)
(syntax-property stx sym (unmarshall-object prop))]
[else stx]))
(define (unmarshall-object obj)
(let ([unknown (λ () (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)))))

433
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -1,263 +1,216 @@
(module widget mzscheme (module widget mzscheme
(require "interfaces.ss" (require (lib "class.ss")
(lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "list.ss")
"interfaces.ss"
"params.ss"
"controller.ss" "controller.ss"
"typesetter.ss" "typesetter.ss"
"hrule-snip.ss" "hrule-snip.ss"
"properties.ss" "properties.ss"
"partition.ss" "partition.ss"
"prefs.ss" "util.ss")
"util.ss" (provide widget@
(lib "list.ss") widget-context-menu-extension@)
(lib "class.ss")
(lib "framework.ss" "framework")
(lib "mred.ss" "mred"))
(provide syntax-controller%
syntax-widget%
syntax-browser-frame%)
(define browser-text% (editor:standard-style-list-mixin text:basic%)) (define widget@
(unit/sig widget^
(import keymap^
context-menu^)
;; syntax-widget% ;; syntax-widget%
;; A syntax-widget creates its own syntax-controller. ;; A syntax-widget creates its own syntax-controller.
(define syntax-widget% (define syntax-widget%
(class* object% (syntax-browser<%> syntax-properties-controller<%>) (class* object% (syntax-browser<%> syntax-properties-controller<%>)
(init parent) (init parent)
(init-field pref:props-percentage)
(define -main-panel (new vertical-panel% (parent parent))) (define -main-panel (new vertical-panel% (parent parent)))
(define -split-panel (new panel:horizontal-dragable% (parent -main-panel))) (define -split-panel (new panel:horizontal-dragable% (parent -main-panel)))
(define -text (new browser-text%)) (define -text (new browser-text%))
(define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text))) (define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text)))
(define -props-panel (new horizontal-panel% (parent -split-panel))) (define -props-panel (new horizontal-panel% (parent -split-panel)))
(define props (new properties-view% (parent -props-panel))) (define props (new properties-view% (parent -props-panel)))
(define -saved-panel-percentages #f) (define props-percentage (pref:props-percentage))
(define controller (define controller
(new syntax-controller% (new syntax-controller%
(properties-controller this))) (properties-controller this)))
;; Set up keymap (new syntax-keymap%
(let ([keymap (send -text get-keymap)]) (editor -text)
(send keymap map-function "rightbutton" "popup-context-window") (context-menu (new context-menu% (widget this))))
(send keymap add-function "popup-context-window"
(lambda (editor event)
(do-popup-context-window editor event)))
)
;; FIXME: Why doesn't this work? ;; FIXME: Why doesn't this work?
#; #;
(when (current-syntax-font-size) (when (current-syntax-font-size)
(let* ([style-list (send -text get-style-list)] (let* ([style-list (send -text get-style-list)]
[standard (send style-list find-named-style "Standard")]) [standard (send style-list find-named-style "Standard")])
(send style-list replace-named-style "Standard" (send style-list replace-named-style "Standard"
(send style-list find-or-create-style (send style-list find-or-create-style
standard standard
(make-object style-delta% 'change-size (make-object style-delta% 'change-size
(current-syntax-font-size)))))) (current-syntax-font-size))))))
(send -text lock #t) (send -text lock #t)
(send -split-panel set-percentages (send -split-panel set-percentages
(let ([pp (pref:props-percentage)]) (list (- 1 pp) pp))) (list (- 1 props-percentage) props-percentage))
(toggle-props) (toggle-props)
(define/private (do-popup-context-window editor event) ;; syntax-properties-controller<%> methods
(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))
(define context-menu (define/public (set-syntax stx)
(let ([context-menu (new popup-menu%)]) (send props set-syntax stx))
(new menu-item% (label "Copy") (parent context-menu)
(callback (lambda (i e)
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
"")
(send e get-time-stamp)))))
;; FIXME: Add option for "formatted" copy/paste?
(new menu-item% (define/public (show ?)
(label "Clear selection") (if ? (show-props) (hide-props)))
(parent context-menu)
(callback (lambda _ (send controller select-syntax #f))))
(new separator-menu-item% (parent context-menu)) (define/public (is-shown?)
(send -props-panel is-shown?))
;; properties (define/public (toggle-props)
(new menu-item% (if (send -props-panel is-shown?)
(label "Show/hide syntax properties") (hide-props)
(parent context-menu) (show-props)))
(define/public (hide-props)
(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 (show-props)
(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)))
;;
(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
(case-lambda
[(stx)
(internal-add-syntax stx null #f)]
[(stx hi-stxs hi-color)
(internal-add-syntax stx hi-stxs hi-color)]))
(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 controller erase))
(define/public (select-syntax stx)
(send controller select-syntax stx))
(define/public (get-text) -text)
(define/private (internal-add-syntax stx hi-stxs hi-color)
(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))
(unless (null? hi-stxs)
(send new-colorer highlight-syntaxes hi-stxs hi-color)))))))
(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)))))
(super-new)))
;; 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)))) (callback (lambda _ (toggle-props))))
;; primary selection (define/private (on-update-identifier=?-choice)
(let ([secondary (new menu% (label "identifier=?") (parent context-menu))]) (cond [(assoc (send -choice get-string-selection)
(for-each -identifier=-choices)
(lambda (name func) => (lambda (p)
(let ([this-choice (send (get-controller)
(new checkable-menu-item% on-update-identifier=? (car p) (cdr p)))]
(label name) [else #f]))
(parent secondary) (send (get-controller) add-identifier=?-listener
(callback (lambda (name func)
(lambda (i e) (send -choice set-selection
(send controller on-update-identifier=? name func))))]) (or (send -choice find-string name) 0))))))
(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))))
context-menu))
;; syntax-properties-controller<%> methods
(define/public (set-syntax stx)
(send props set-syntax stx))
(define/public (show ?)
(if ? (show-props) (hide-props)))
(define/public (is-shown?)
(send -props-panel is-shown?))
(define/public (toggle-props)
(if (send -props-panel is-shown?)
(hide-props)
(show-props)))
(define/public (hide-props)
(when (send -props-panel is-shown?)
(set! -saved-panel-percentages (send -split-panel get-percentages))
(send -split-panel delete-child -props-panel)
(send -props-panel show #f)))
(define/public (show-props)
(unless (send -props-panel is-shown?)
(send -split-panel add-child -props-panel)
(send -split-panel set-percentages -saved-panel-percentages)
(send -props-panel show #t)))
;;
(define/public (get-controller) controller)
;;
(define/public (get-main-panel) -main-panel)
(define/public (on-close)
(unless (= (cadr -saved-panel-percentages) (pref:props-percentage))
(pref:props-percentage (cadr -saved-panel-percentages))))
;; syntax-browser<%> Methods
(define/public (add-text text)
(with-unlock -text
(send -text insert text)))
(define/public add-syntax
(case-lambda
[(stx)
(internal-add-syntax stx null #f)]
[(stx hi-stxs hi-color)
(internal-add-syntax stx hi-stxs hi-color)]))
(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 controller erase))
(define/public (select-syntax stx)
(send controller select-syntax stx))
(define/public (get-text) -text)
(define/private (internal-add-syntax stx hi-stxs hi-color)
(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))
(unless (null? hi-stxs)
(send new-colorer highlight-syntaxes hi-stxs hi-color)))))))
(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)))))
(super-new)))
;; 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))))))
;; 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)))
(define/public (get-widget) widget)
(define/augment (on-close)
(pref:width (send this get-width))
(pref:height (send this get-height))
(send widget on-close)
(preferences:save)
(inner (void) on-close))
)) ))
(define widget-context-menu-extension@
(unit/sig context-menu^
(import (pre : context-menu^))
(define context-menu%
(class pre:context-menu%
(init-field widget)
(define/override (after-selection-items)
(super after-selection-items)
(new menu-item% (label "Show/hide syntax properties")
(parent this)
(callback (lambda _ (send widget toggle-props))))
(void))
(super-new (controller (send widget get-controller)))))))
(define browser-text% (editor:standard-style-list-mixin text:basic%))
) )

5
collects/macro-debugger/view/prefs.ss Normal file
View File

@ -0,0 +1,5 @@
(module prefs mzscheme
(require (lib "framework.ss" "framework"))
'...)

11
collects/macro-debugger/view/view.ss
View File

@ -1,13 +1,16 @@
(module view mzscheme (module view mzscheme
(require (lib "unitsig.ss")) (require (lib "unitsig.ss")
(require "gui.ss") (prefix sb: "../syntax-browser/embed.ss")
"gui.ss")
(provide (all-defined)) (provide (all-defined))
(define-values/invoke-unit/sig view^ (define-values/invoke-unit/sig view^
(compound-unit/sig (compound-unit/sig
(import) (import)
(link (BASE : view-base^ (view-base@)) (link (PREFS : sb:prefs^ (sb:global-prefs@))
(VIEW : view^ (view@ BASE))) (SB : sb:implementation^ (sb:implementation@))
(BASE : view-base^ (view-base@))
(VIEW : view^ (view@ BASE PREFS SB)))
(export (open VIEW)))) (export (open VIEW))))
) )