Reorganized syntax-browser

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

View File

@ -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)
)

View File

@ -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))

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))

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))
))))
)

View File

@ -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:

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)
))))
)

View File

@ -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)))
)

View File

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

View File

@ -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%

View File

@ -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)))))
)

View File

@ -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%))
)

View File

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

View File

@ -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))))
)