Reorganized syntax-browser
svn: r4500 original commit: 2954ed58441dd1cdf4492a9bc2362c41fc6288d2
This commit is contained in:
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,10 +1,9 @@
|
|||
|
||||
(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 ()
|
||||
|
@ -14,6 +13,10 @@
|
|||
[() (preferences:get 'prop)]
|
||||
[(newval) (preferences:set 'prop newval)]))]))
|
||||
|
||||
(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?)
|
||||
|
@ -22,6 +25,6 @@
|
|||
(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: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,32 +1,36 @@
|
|||
|
||||
(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%)
|
||||
"controller.ss"
|
||||
"properties.ss"
|
||||
"typesetter.ss")
|
||||
(provide snip@
|
||||
snip-context-menu-extension@)
|
||||
|
||||
(define snip@
|
||||
(unit/sig snip^
|
||||
(import prefs^
|
||||
keymap^
|
||||
context-menu^
|
||||
snipclass^)
|
||||
|
||||
;; syntax-snip : syntax -> snip
|
||||
(define (syntax-snip stx)
|
||||
(new syntax-snip% (syntax stx)))
|
||||
|
||||
(define current-syntax-controller (make-parameter #f))
|
||||
(define *syntax-controller* #f)
|
||||
|
||||
(define (the-syntax-controller)
|
||||
(let ([controller (current-syntax-controller)])
|
||||
(let ([controller *syntax-controller*])
|
||||
(or controller
|
||||
(let ([controller (new syntax-controller%)])
|
||||
(current-syntax-controller controller)
|
||||
(let* ([controller (new syntax-controller%)]
|
||||
[props (new independent-properties-controller% (controller controller))])
|
||||
(send controller set-properties-controller props)
|
||||
(set! *syntax-controller* controller)
|
||||
controller))))
|
||||
|
||||
;; syntax-value-snip%
|
||||
|
@ -41,8 +45,14 @@
|
|||
(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)
|
||||
|
@ -54,7 +64,7 @@
|
|||
(send -outer end-edit-sequence)
|
||||
(send -outer hide-caret #t))
|
||||
|
||||
(define/private (show-props)
|
||||
(define/public (show-props)
|
||||
(send (send controller get-properties-controller)
|
||||
show #t))
|
||||
|
||||
|
@ -72,86 +82,15 @@
|
|||
(when clickback
|
||||
(send -outer set-clickback start end clickback))))]))
|
||||
|
||||
;; 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
|
||||
|
||||
;; 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
|
||||
#;(datum->syntax-object #f
|
||||
`(,#'quote-syntax ,stx)
|
||||
(list src line col pos 1)))
|
||||
|
||||
(list src line col pos 1))
|
||||
#`(force '#,(delay stx)))
|
||||
))
|
||||
|
||||
(define syntax-snip%
|
||||
|
@ -169,6 +108,10 @@
|
|||
(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)))
|
||||
|
@ -233,6 +176,48 @@
|
|||
(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 snip-context-menu-extension@
|
||||
(unit/sig context-menu^
|
||||
(import (pre : context-menu^))
|
||||
|
||||
(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
|
||||
(let ([s (make-object style-delta% 'change-normal)])
|
||||
|
@ -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)
|
||||
|
@ -301,57 +270,4 @@
|
|||
(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,28 +1,32 @@
|
|||
|
||||
(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%))
|
||||
(define widget@
|
||||
(unit/sig widget^
|
||||
(import keymap^
|
||||
context-menu^)
|
||||
|
||||
;; 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)))
|
||||
|
@ -30,19 +34,15 @@
|
|||
(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 props-percentage (pref:props-percentage))
|
||||
|
||||
(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)))
|
||||
)
|
||||
(new syntax-keymap%
|
||||
(editor -text)
|
||||
(context-menu (new context-menu% (widget this))))
|
||||
|
||||
;; FIXME: Why doesn't this work?
|
||||
#;
|
||||
|
@ -57,60 +57,9 @@
|
|||
|
||||
(send -text lock #t)
|
||||
(send -split-panel set-percentages
|
||||
(let ([pp (pref:props-percentage)]) (list (- 1 pp) pp)))
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(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 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?
|
||||
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent context-menu)
|
||||
(callback (lambda _ (send controller select-syntax #f))))
|
||||
|
||||
(new separator-menu-item% (parent context-menu))
|
||||
|
||||
;; properties
|
||||
(new menu-item%
|
||||
(label "Show/hide syntax properties")
|
||||
(parent context-menu)
|
||||
(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)
|
||||
|
@ -129,14 +78,15 @@
|
|||
|
||||
(define/public (hide-props)
|
||||
(when (send -props-panel is-shown?)
|
||||
(set! -saved-panel-percentages (send -split-panel get-percentages))
|
||||
(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 -saved-panel-percentages)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(send -props-panel show #t)))
|
||||
|
||||
;;
|
||||
|
@ -147,9 +97,9 @@
|
|||
|
||||
(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))))
|
||||
(define/public (save-prefs)
|
||||
(unless (= props-percentage (pref:props-percentage))
|
||||
(pref:props-percentage props-percentage)))
|
||||
|
||||
;; syntax-browser<%> Methods
|
||||
|
||||
|
@ -208,7 +158,6 @@
|
|||
(inherit get-main-panel
|
||||
get-controller
|
||||
toggle-props)
|
||||
|
||||
(super-new)
|
||||
|
||||
(define -control-panel
|
||||
|
@ -244,20 +193,24 @@
|
|||
(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
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