Fixed location bug with popup menu
Improved syntax snips svn: r4492
This commit is contained in:
Ryan Culpepper
parent
19ce52a1ea
commit
bc02b021b9
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
(module syntax-browser mzscheme
|
||||
(require "syntax-browser/syntax-browser.ss")
|
||||
(require "syntax-browser/syntax-browser.ss"
|
||||
"syntax-browser/syntax-snip.ss")
|
||||
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
(provide (all-defined))
|
||||
|
||||
(define current-syntax-font-size (make-parameter #f #;16))
|
||||
(define current-default-columns (make-parameter 40))
|
||||
(define current-default-columns (make-parameter 60))
|
||||
|
||||
(define-syntax pref:get/set
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -16,28 +16,14 @@
|
|||
|
||||
;; Properties display
|
||||
(define parent
|
||||
(new frame% (label "Properties and Configuration") (height (pref:height))
|
||||
(new frame% (label "Properties") (height (pref:height))
|
||||
(width (floor (* (pref:props-percentage) (pref:width))))))
|
||||
(define choice (new choice% (label "identifer=?") (parent parent)
|
||||
(choices (map car (identifier=-choices)))
|
||||
(callback (lambda _ (on-update-identifier=?-choice)))))
|
||||
(new message% (label " ") (parent parent))
|
||||
(define pv (new properties-view% (parent parent)))
|
||||
|
||||
(define/private (show-properties)
|
||||
(unless (send parent is-shown?)
|
||||
(send parent show #t)))
|
||||
|
||||
(define/private (on-update-identifier=?-choice)
|
||||
(let ([id=? (get-identifier=?)])
|
||||
(send controller on-update-identifier=? id=?)))
|
||||
|
||||
(define/private (get-identifier=?)
|
||||
(cond [(assoc (send choice get-string-selection)
|
||||
(identifier=-choices))
|
||||
=> cdr]
|
||||
[else #f]))
|
||||
|
||||
(define/public (set-syntax stx)
|
||||
(send pv set-syntax stx))
|
||||
(define/public (show ?)
|
||||
|
|
|
|||
|
|
@ -1,17 +1,12 @@
|
|||
|
||||
(module syntax-browser mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"syntax-snip.ss"
|
||||
"widget.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
syntax-browser<%>
|
||||
make-syntax-browser
|
||||
syntax-snip)
|
||||
make-syntax-browser)
|
||||
|
||||
;; browse-syntax : syntax -> void
|
||||
(define (browse-syntax stx)
|
||||
|
|
@ -31,22 +26,4 @@
|
|||
(send view show #t)
|
||||
(send view get-widget)))
|
||||
|
||||
;; syntax-snip : syntax -> snip
|
||||
(define (syntax-snip stx)
|
||||
(new super-syntax-snip% (syntax stx)))
|
||||
|
||||
; ;; syntaxes-snip : syntaxes -> snip
|
||||
; (define (syntaxes-snip stxs)
|
||||
; (let* ([controller (new syntax-controller%)]
|
||||
; [view (new syntax-snip% (controller controller))])
|
||||
; (let loop ([stxs stxs])
|
||||
; (cond [(null? stxs) (void)]
|
||||
; [(null? (cdr stxs))
|
||||
; (send controller add-syntax (car stxs))]
|
||||
; [else
|
||||
; (send controller add-syntax (car stxs))
|
||||
; #;(send controller add-separator)
|
||||
; (loop (cdr stxs))]))
|
||||
; view))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,15 +1,24 @@
|
|||
|
||||
(module syntax-snip mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "match.ss")
|
||||
(lib "list.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "string.ss")
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"properties.ss"
|
||||
"partition.ss"
|
||||
"typesetter.ss"
|
||||
"widget.ss"
|
||||
"partition.ss")
|
||||
(provide syntax-snip%
|
||||
super-syntax-snip%)
|
||||
"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))
|
||||
|
||||
|
|
@ -20,39 +29,34 @@
|
|||
(current-syntax-controller controller)
|
||||
controller))))
|
||||
|
||||
|
||||
;; syntax-snip%
|
||||
(define syntax-snip%
|
||||
(class* editor-snip% ()
|
||||
;; 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%))
|
||||
(super-new (editor -outer))
|
||||
(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)
|
||||
|
||||
;; Initialization
|
||||
(define/private (refresh)
|
||||
(send -outer begin-edit-sequence)
|
||||
(initialize -outer)
|
||||
(outer:insert "Syntax browser" style:bold)
|
||||
(outer:insert " ")
|
||||
(outer:insert "Clear" style:hyper
|
||||
(lambda (x y z) (send controller select-syntax #f)))
|
||||
(outer:insert " ")
|
||||
(outer:insert "Properties" style:hyper
|
||||
(lambda (x y z)
|
||||
(send (send controller get-properties-controller)
|
||||
show #t)))
|
||||
(outer:insert "\n")
|
||||
(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)
|
||||
(send -outer hide-caret #t))
|
||||
|
||||
(define/public (initialize outer)
|
||||
(void))
|
||||
(define/private (show-props)
|
||||
(send (send controller get-properties-controller)
|
||||
show #t))
|
||||
|
||||
(define/private outer:insert
|
||||
(case-lambda
|
||||
|
|
@ -68,19 +72,166 @@
|
|||
(when clickback
|
||||
(send -outer set-clickback start end clickback))))]))
|
||||
|
||||
;; snip% Methods
|
||||
;; 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-snip% (controller controller) (syntax stx)))
|
||||
(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)))
|
||||
|
||||
))
|
||||
|
||||
(define subservient-syntax-snip%
|
||||
(class syntax-snip%
|
||||
(init-field f)
|
||||
(define/override (initialize outer)
|
||||
(f outer))
|
||||
(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/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 style:normal (make-object style-delta% 'change-normal))
|
||||
(define style:hyper
|
||||
|
|
@ -93,62 +244,114 @@
|
|||
(send s set-delta 'change-bold)
|
||||
s))
|
||||
|
||||
(define (show-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-up.png")))
|
||||
(define (hide-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-down.png")))
|
||||
(define (show-icon)
|
||||
(make-object image-snip%
|
||||
(build-path (collection-path "icons") "turn-up.png")))
|
||||
(define (hide-icon)
|
||||
(make-object image-snip%
|
||||
(build-path (collection-path "icons") "turn-down.png")))
|
||||
|
||||
(define super-syntax-snip%
|
||||
(class* editor-snip% ()
|
||||
(init-field ((stx syntax)))
|
||||
(init-field (controller (the-syntax-controller)))
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
|
||||
|
||||
(define -outer (new text%))
|
||||
(super-new (editor -outer) (with-border? #f))
|
||||
(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/private (hide-me)
|
||||
(send* -outer
|
||||
(lock #f)
|
||||
(erase))
|
||||
(outer:insert (show-icon) style:hyper (lambda _ (show-me)))
|
||||
(outer:insert "#<syntax>")
|
||||
(send -outer lock #t))
|
||||
(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)
|
||||
|
||||
(define/private (show-me)
|
||||
(send* -outer
|
||||
(lock #f)
|
||||
(erase))
|
||||
(outer:insert (new subservient-syntax-snip%
|
||||
(syntax stx)
|
||||
(controller controller)
|
||||
(f (lambda (t)
|
||||
(let* ([start (send t last-position)]
|
||||
[_ (send t insert (hide-icon))]
|
||||
[end (send t last-position)])
|
||||
(send t insert " ")
|
||||
(send t change-style style:hyper start end #f)
|
||||
(send t set-clickback start end (lambda _ (hide-me))))))))
|
||||
(send* -outer
|
||||
(lock #t)))
|
||||
;; marshall-syntax : syntax -> printable
|
||||
(define (marshall-syntax stx)
|
||||
(unless (syntax? stx)
|
||||
(error 'marshall-syntax "not syntax: ~s\n" stx))
|
||||
`(syntax
|
||||
(source ,(marshall-object (syntax-source stx)))
|
||||
(source-module ,(marshall-object (syntax-source-module stx)))
|
||||
(position ,(syntax-position stx))
|
||||
(line ,(syntax-line stx))
|
||||
(column ,(syntax-column stx))
|
||||
(span ,(syntax-span stx))
|
||||
(original? ,(syntax-original? stx))
|
||||
(properties
|
||||
,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
|
||||
(syntax-property-symbol-keys stx)))
|
||||
(contents
|
||||
,(marshall-object (syntax-e stx)))))
|
||||
|
||||
(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))))]))
|
||||
;; marshall-object : any -> printable
|
||||
;; really only intended for use with marshall-syntax
|
||||
(define (marshall-object obj)
|
||||
(cond
|
||||
[(syntax? obj) (marshall-syntax obj)]
|
||||
[(pair? obj)
|
||||
`(pair ,(cons (marshall-object (car obj))
|
||||
(marshall-object (cdr obj))))]
|
||||
[(or (symbol? obj)
|
||||
(char? obj)
|
||||
(number? obj)
|
||||
(string? obj)
|
||||
(boolean? obj)
|
||||
(null? obj))
|
||||
`(other ,obj)]
|
||||
[else (string->symbol (format "unknown-object: ~s" obj))]))
|
||||
|
||||
(define/override (copy)
|
||||
(new super-syntax-snip% (controller controller) (syntax stx)))
|
||||
(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]))
|
||||
|
||||
(hide-me)
|
||||
(send -outer hide-caret #t)
|
||||
(send -outer lock #t)
|
||||
))
|
||||
;; 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)))))
|
||||
|
|
|
|||
|
|
@ -61,8 +61,10 @@
|
|||
(toggle-props)
|
||||
|
||||
(define/private (do-popup-context-window editor event)
|
||||
(define x (send event get-x))
|
||||
(define y (send event get-y))
|
||||
(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))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user