From 9599b2253b733881fcd7da95e12a01c43eb7ac72 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 6 Oct 2006 02:26:04 +0000 Subject: [PATCH] Reorganized syntax-browser svn: r4500 original commit: 2954ed58441dd1cdf4492a9bc2362c41fc6288d2 --- collects/macro-debugger/syntax-browser.ss | 8 +- .../syntax-browser/controller.ss | 8 +- .../macro-debugger/syntax-browser/embed.ss | 11 + .../macro-debugger/syntax-browser/frame.ss | 51 ++ .../syntax-browser/interfaces.ss | 60 ++- .../macro-debugger/syntax-browser/keymap.ss | 123 +++++ .../macro-debugger/syntax-browser/prefs.ss | 33 +- .../syntax-browser/pretty-printer.ss | 2 +- .../syntax-browser/properties.ss | 30 +- .../syntax-browser/syntax-snip.ss | 506 ++++++++---------- .../macro-debugger/syntax-browser/widget.ss | 449 +++++++--------- collects/macro-debugger/view/prefs.ss | 5 + collects/macro-debugger/view/view.ss | 13 +- 13 files changed, 698 insertions(+), 601 deletions(-) create mode 100644 collects/macro-debugger/syntax-browser/embed.ss create mode 100644 collects/macro-debugger/syntax-browser/frame.ss create mode 100644 collects/macro-debugger/syntax-browser/keymap.ss create mode 100644 collects/macro-debugger/view/prefs.ss diff --git a/collects/macro-debugger/syntax-browser.ss b/collects/macro-debugger/syntax-browser.ss index 44799d3..ccc0cde 100644 --- a/collects/macro-debugger/syntax-browser.ss +++ b/collects/macro-debugger/syntax-browser.ss @@ -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) + ) diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index ac7f684..5f0d78d 100644 --- a/collects/macro-debugger/syntax-browser/controller.ss +++ b/collects/macro-debugger/syntax-browser/controller.ss @@ -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)) diff --git a/collects/macro-debugger/syntax-browser/embed.ss b/collects/macro-debugger/syntax-browser/embed.ss new file mode 100644 index 0000000..176120b --- /dev/null +++ b/collects/macro-debugger/syntax-browser/embed.ss @@ -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)) diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.ss new file mode 100644 index 0000000..1257840 --- /dev/null +++ b/collects/macro-debugger/syntax-browser/frame.ss @@ -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)) + )))) + ) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index 9fa4ead..add1a86 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -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: diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss new file mode 100644 index 0000000..14e6201 --- /dev/null +++ b/collects/macro-debugger/syntax-browser/keymap.ss @@ -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) + + )))) + ) diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 0491dde..944ec9e 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -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))) ) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index efd1632..1cd5d36 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -9,7 +9,7 @@ "pretty-range.ss" "pretty-helper.ss" "interfaces.ss" - "prefs.ss") + "params.ss") (provide syntax-pp% (struct range (obj start end))) diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss index 23544ec..00965ea 100644 --- a/collects/macro-debugger/syntax-browser/properties.ss +++ b/collects/macro-debugger/syntax-browser/properties.ss @@ -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% diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index fbb78be..750f3f0 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -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 "#" line col) + "#"))) + + (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 "#" line col) - "#"))) + (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))))) + ) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 24831b0..02ff0fd 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -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%)) ) diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss new file mode 100644 index 0000000..bf3f4bd --- /dev/null +++ b/collects/macro-debugger/view/prefs.ss @@ -0,0 +1,5 @@ + +(module prefs mzscheme + (require (lib "framework.ss" "framework")) + + '...) diff --git a/collects/macro-debugger/view/view.ss b/collects/macro-debugger/view/view.ss index 166e398..ee854d3 100644 --- a/collects/macro-debugger/view/view.ss +++ b/collects/macro-debugger/view/view.ss @@ -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)))) - ) \ No newline at end of file + )