Reorganized syntax-browser
svn: r4500 original commit: 2954ed58441dd1cdf4492a9bc2362c41fc6288d2
This commit is contained in:
Ryan Culpepper
parent
5f1b8d4da6
commit
9599b2253b
|
|
@ -1,8 +1,8 @@
|
|||
|
||||
(module syntax-browser mzscheme
|
||||
(require "syntax-browser/syntax-browser.ss"
|
||||
"syntax-browser/syntax-snip.ss")
|
||||
|
||||
(require "syntax-browser/browser.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
syntax-snip))
|
||||
make-syntax-browser
|
||||
syntax-snip)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
(module controller mzscheme
|
||||
(require (lib "class.ss")
|
||||
"interfaces.ss"
|
||||
"partition.ss"
|
||||
"properties.ss")
|
||||
"partition.ss")
|
||||
|
||||
(provide syntax-controller%)
|
||||
|
||||
|
|
@ -17,8 +16,7 @@
|
|||
(define selection-listeners null)
|
||||
(define selected-syntax #f)
|
||||
(define identifier=?-listeners null)
|
||||
(init-field (properties-controller
|
||||
(new independent-properties-controller% (controller this))))
|
||||
(init-field (properties-controller #f))
|
||||
|
||||
;; syntax-controller<%> Methods
|
||||
|
||||
|
|
@ -31,6 +29,8 @@
|
|||
(define/public (get-selected-syntax) selected-syntax)
|
||||
|
||||
(define/public (get-properties-controller) properties-controller)
|
||||
(define/public (set-properties-controller pc)
|
||||
(set! properties-controller pc))
|
||||
|
||||
(define/public (add-view-colorer c)
|
||||
(set! colorers (cons c colorers))
|
||||
|
|
|
|||
11
collects/macro-debugger/syntax-browser/embed.ss
Normal file
11
collects/macro-debugger/syntax-browser/embed.ss
Normal 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
51
collects/macro-debugger/syntax-browser/frame.ss
Normal 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))
|
||||
))))
|
||||
)
|
||||
|
|
@ -1,8 +1,66 @@
|
|||
|
||||
(module interfaces mzscheme
|
||||
(require (lib "class.ss"))
|
||||
(require (lib "class.ss")
|
||||
(lib "unitsig.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-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<%>
|
||||
;; A syntax-controller coordinates state shared by many different syntax views.
|
||||
;; Syntax views can share:
|
||||
|
|
|
|||
123
collects/macro-debugger/syntax-browser/keymap.ss
Normal file
123
collects/macro-debugger/syntax-browser/keymap.ss
Normal 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)
|
||||
|
||||
))))
|
||||
)
|
||||
|
|
@ -1,11 +1,10 @@
|
|||
|
||||
(module prefs mzscheme
|
||||
(require (lib "framework.ss" "framework"))
|
||||
(provide (all-defined))
|
||||
|
||||
(define current-syntax-font-size (make-parameter #f #;16))
|
||||
(define current-default-columns (make-parameter 60))
|
||||
|
||||
(require (lib "unitsig.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"interfaces.ss")
|
||||
(provide prefs@)
|
||||
|
||||
(define-syntax pref:get/set
|
||||
(syntax-rules ()
|
||||
[(_ get/set prop)
|
||||
|
|
@ -14,14 +13,18 @@
|
|||
[() (preferences:get 'prop)]
|
||||
[(newval) (preferences:set 'prop newval)]))]))
|
||||
|
||||
(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)
|
||||
(define prefs@
|
||||
(unit/sig prefs^
|
||||
(import)
|
||||
|
||||
(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)))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
"pretty-range.ss"
|
||||
"pretty-helper.ss"
|
||||
"interfaces.ss"
|
||||
"prefs.ss")
|
||||
"params.ss")
|
||||
(provide syntax-pp%
|
||||
(struct range (obj start end)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,36 +1,10 @@
|
|||
|
||||
(module properties mzscheme
|
||||
(require "prefs.ss"
|
||||
"interfaces.ss"
|
||||
"partition.ss"
|
||||
(require "interfaces.ss"
|
||||
"util.ss"
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
(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)))
|
||||
(provide properties-view%)
|
||||
|
||||
;; properties-view%
|
||||
(define properties-view%
|
||||
|
|
|
|||
|
|
@ -1,237 +1,222 @@
|
|||
|
||||
(module syntax-snip mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "match.ss")
|
||||
(lib "list.ss")
|
||||
(lib "unitsig.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "string.ss")
|
||||
"interfaces.ss"
|
||||
"partition.ss"
|
||||
"typesetter.ss"
|
||||
"widget.ss"
|
||||
"syntax-browser.ss")
|
||||
(provide syntax-snip
|
||||
snip-class
|
||||
syntax-value-snip%
|
||||
syntax-snip%)
|
||||
|
||||
;; syntax-snip : syntax -> snip
|
||||
(define (syntax-snip stx)
|
||||
(new syntax-snip% (syntax stx)))
|
||||
|
||||
(define current-syntax-controller (make-parameter #f))
|
||||
|
||||
(define (the-syntax-controller)
|
||||
(let ([controller (current-syntax-controller)])
|
||||
(or controller
|
||||
(let ([controller (new syntax-controller%)])
|
||||
(current-syntax-controller controller)
|
||||
controller))))
|
||||
|
||||
;; 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 -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)
|
||||
(refresh)
|
||||
|
||||
(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/private (show-props)
|
||||
(send (send controller get-properties-controller)
|
||||
show #t))
|
||||
"controller.ss"
|
||||
"properties.ss"
|
||||
"typesetter.ss")
|
||||
(provide snip@
|
||||
snip-context-menu-extension@)
|
||||
|
||||
(define snip@
|
||||
(unit/sig snip^
|
||||
(import prefs^
|
||||
keymap^
|
||||
context-menu^
|
||||
snipclass^)
|
||||
|
||||
(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))))]))
|
||||
;; syntax-snip : syntax -> snip
|
||||
(define (syntax-snip stx)
|
||||
(new syntax-snip% (syntax stx)))
|
||||
|
||||
;; BEGIN COPIED from widget.ss
|
||||
;; WITH MODIFICATIONS
|
||||
;; Set up keymap
|
||||
(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
|
||||
(define *syntax-controller* #f)
|
||||
|
||||
;; snip% Methods
|
||||
(define/override (copy)
|
||||
(new syntax-value-snip% (controller controller) (syntax stx)))
|
||||
(define (the-syntax-controller)
|
||||
(let ([controller *syntax-controller*])
|
||||
(or controller
|
||||
(let* ([controller (new syntax-controller%)]
|
||||
[props (new independent-properties-controller% (controller controller))])
|
||||
(send controller set-properties-controller props)
|
||||
(set! *syntax-controller* controller)
|
||||
controller))))
|
||||
|
||||
(define/public (read-special src line col pos)
|
||||
(datum->syntax-object #f
|
||||
`(,#'quote-syntax ,stx)
|
||||
(list src line col pos 1)))
|
||||
;; 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 -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)
|
||||
(context-menu (new context-menu% (snip this))))
|
||||
(refresh)
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
(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)))
|
||||
|
||||
(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%
|
||||
(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)
|
||||
|
||||
(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 snip-context-menu-extension@
|
||||
(unit/sig context-menu^
|
||||
(import (pre : context-menu^))
|
||||
|
||||
(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)
|
||||
))
|
||||
(define context-menu%
|
||||
(class pre:context-menu%
|
||||
(init-field snip)
|
||||
|
||||
(define/override (after-selection-items)
|
||||
(super after-selection-items)
|
||||
(new menu-item% (label "Show syntax properties")
|
||||
(parent this)
|
||||
(callback (lambda _ (send snip show-props))))
|
||||
(void))
|
||||
|
||||
(super-new (controller (send snip get-controller)))))))
|
||||
|
||||
|
||||
(define style:normal (make-object style-delta% 'change-normal))
|
||||
(define style:hyper
|
||||
|
|
@ -243,7 +228,7 @@
|
|||
(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")))
|
||||
|
|
@ -251,22 +236,6 @@
|
|||
(make-object image-snip%
|
||||
(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
|
||||
(define (marshall-syntax stx)
|
||||
(unless (syntax? stx)
|
||||
|
|
@ -284,7 +253,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)
|
||||
|
|
@ -294,64 +263,11 @@
|
|||
`(pair ,(cons (marshall-object (car obj))
|
||||
(marshall-object (cdr obj))))]
|
||||
[(or (symbol? obj)
|
||||
(char? obj)
|
||||
(number? obj)
|
||||
(char? obj)
|
||||
(number? obj)
|
||||
(string? obj)
|
||||
(boolean? obj)
|
||||
(boolean? obj)
|
||||
(null? obj))
|
||||
`(other ,obj)]
|
||||
[else (string->symbol (format "unknown-object: ~s" obj))]))
|
||||
|
||||
(define (unmarshall-syntax stx)
|
||||
(match stx
|
||||
[`(syntax
|
||||
(source ,src)
|
||||
(source-module ,source-module) ;; marshalling
|
||||
(position ,pos)
|
||||
(line ,line)
|
||||
(column ,col)
|
||||
(span ,span)
|
||||
(original? ,original?)
|
||||
(properties ,@(properties ...))
|
||||
(contents ,contents))
|
||||
(foldl
|
||||
add-properties
|
||||
(datum->syntax-object
|
||||
#'here ;; ack
|
||||
(unmarshall-object contents)
|
||||
(list (unmarshall-object src)
|
||||
line
|
||||
col
|
||||
pos
|
||||
span))
|
||||
properties)]
|
||||
[else #'unknown-syntax-object]))
|
||||
|
||||
;; add-properties : syntax any -> syntax
|
||||
(define (add-properties prop-spec stx)
|
||||
(match prop-spec
|
||||
[`(,(and sym (? symbol?))
|
||||
,prop)
|
||||
(syntax-property stx sym (unmarshall-object prop))]
|
||||
[else stx]))
|
||||
|
||||
(define (unmarshall-object obj)
|
||||
(let ([unknown (λ () (string->symbol (format "unknown: ~s" obj)))])
|
||||
(if (and (pair? obj)
|
||||
(symbol? (car obj)))
|
||||
(case (car obj)
|
||||
[(pair)
|
||||
(if (pair? (cdr obj))
|
||||
(let ([raw-obj (cadr obj)])
|
||||
(if (pair? raw-obj)
|
||||
(cons (unmarshall-object (car raw-obj))
|
||||
(unmarshall-object (cdr raw-obj)))
|
||||
(unknown)))
|
||||
(unknown))]
|
||||
[(other)
|
||||
(if (pair? (cdr obj))
|
||||
(cadr obj)
|
||||
(unknown))]
|
||||
[(syntax) (unmarshall-syntax obj)]
|
||||
[else (unknown)])
|
||||
(unknown)))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,263 +1,216 @@
|
|||
|
||||
(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"
|
||||
"typesetter.ss"
|
||||
"hrule-snip.ss"
|
||||
"properties.ss"
|
||||
"partition.ss"
|
||||
"prefs.ss"
|
||||
"util.ss"
|
||||
(lib "list.ss")
|
||||
(lib "class.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "mred.ss" "mred"))
|
||||
(provide syntax-controller%
|
||||
syntax-widget%
|
||||
syntax-browser-frame%)
|
||||
"util.ss")
|
||||
(provide widget@
|
||||
widget-context-menu-extension@)
|
||||
|
||||
(define browser-text% (editor:standard-style-list-mixin text:basic%))
|
||||
|
||||
;; syntax-widget%
|
||||
;; A syntax-widget creates its own syntax-controller.
|
||||
(define syntax-widget%
|
||||
(class* object% (syntax-browser<%> syntax-properties-controller<%>)
|
||||
(init parent)
|
||||
|
||||
(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 -saved-panel-percentages #f)
|
||||
|
||||
(define controller
|
||||
(new syntax-controller%
|
||||
(properties-controller this)))
|
||||
|
||||
;; Set up keymap
|
||||
(let ([keymap (send -text 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)))
|
||||
)
|
||||
|
||||
;; FIXME: Why doesn't this work?
|
||||
#;
|
||||
(when (current-syntax-font-size)
|
||||
(let* ([style-list (send -text get-style-list)]
|
||||
[standard (send style-list find-named-style "Standard")])
|
||||
(send style-list replace-named-style "Standard"
|
||||
(send style-list find-or-create-style
|
||||
standard
|
||||
(make-object style-delta% 'change-size
|
||||
(current-syntax-font-size))))))
|
||||
|
||||
(send -text lock #t)
|
||||
(send -split-panel set-percentages
|
||||
(let ([pp (pref:props-percentage)]) (list (- 1 pp) pp)))
|
||||
(toggle-props)
|
||||
|
||||
(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 widget@
|
||||
(unit/sig widget^
|
||||
(import keymap^
|
||||
context-menu^)
|
||||
|
||||
(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)))))
|
||||
;; FIXME: Add option for "formatted" copy/paste?
|
||||
;; 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)
|
||||
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent context-menu)
|
||||
(callback (lambda _ (send controller select-syntax #f))))
|
||||
|
||||
(new separator-menu-item% (parent context-menu))
|
||||
(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))
|
||||
|
||||
;; properties
|
||||
(new menu-item%
|
||||
(label "Show/hide syntax properties")
|
||||
(parent context-menu)
|
||||
(define controller
|
||||
(new syntax-controller%
|
||||
(properties-controller this)))
|
||||
|
||||
(new syntax-keymap%
|
||||
(editor -text)
|
||||
(context-menu (new context-menu% (widget this))))
|
||||
|
||||
;; FIXME: Why doesn't this work?
|
||||
#;
|
||||
(when (current-syntax-font-size)
|
||||
(let* ([style-list (send -text get-style-list)]
|
||||
[standard (send style-list find-named-style "Standard")])
|
||||
(send style-list replace-named-style "Standard"
|
||||
(send style-list find-or-create-style
|
||||
standard
|
||||
(make-object style-delta% 'change-size
|
||||
(current-syntax-font-size))))))
|
||||
|
||||
(send -text lock #t)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(toggle-props)
|
||||
|
||||
;; 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! 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))))
|
||||
|
||||
;; 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))
|
||||
|
||||
;; 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/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))))))
|
||||
))
|
||||
|
||||
(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
5
collects/macro-debugger/view/prefs.ss
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
|
||||
(module prefs mzscheme
|
||||
(require (lib "framework.ss" "framework"))
|
||||
|
||||
'...)
|
||||
|
|
@ -1,13 +1,16 @@
|
|||
|
||||
(module view mzscheme
|
||||
(require (lib "unitsig.ss"))
|
||||
(require "gui.ss")
|
||||
(require (lib "unitsig.ss")
|
||||
(prefix sb: "../syntax-browser/embed.ss")
|
||||
"gui.ss")
|
||||
(provide (all-defined))
|
||||
|
||||
(define-values/invoke-unit/sig view^
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link (BASE : view-base^ (view-base@))
|
||||
(VIEW : view^ (view@ BASE)))
|
||||
(link (PREFS : sb:prefs^ (sb:global-prefs@))
|
||||
(SB : sb:implementation^ (sb:implementation@))
|
||||
(BASE : view-base^ (view-base@))
|
||||
(VIEW : view^ (view@ BASE PREFS SB)))
|
||||
(export (open VIEW))))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user