From 2954ed58441dd1cdf4492a9bc2362c41fc6288d2 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 --- collects/macro-debugger/syntax-browser.ss | 8 +- .../macro-debugger/syntax-browser/browser.ss | 19 + .../syntax-browser/controller.ss | 8 +- .../macro-debugger/syntax-browser/embed.ss | 11 + .../macro-debugger/syntax-browser/frame.ss | 51 ++ .../syntax-browser/implementation.ss | 64 +++ .../syntax-browser/interfaces.ss | 60 ++- .../macro-debugger/syntax-browser/keymap.ss | 123 +++++ .../macro-debugger/syntax-browser/params.ss | 13 + .../macro-debugger/syntax-browser/prefs.ss | 33 +- .../syntax-browser/pretty-printer.ss | 2 +- .../syntax-browser/properties.ss | 30 +- .../syntax-browser/snipclass.ss | 84 +++ .../syntax-browser/syntax-browser.ss | 26 - .../syntax-browser/syntax-snip.ss | 506 ++++++++---------- .../syntax-browser/typesetter.ss | 2 +- .../macro-debugger/syntax-browser/widget.ss | 449 +++++++--------- collects/macro-debugger/tool.ss | 16 +- collects/macro-debugger/view/gui.ss | 18 +- collects/macro-debugger/view/prefs.ss | 5 + collects/macro-debugger/view/view.ss | 13 +- 21 files changed, 897 insertions(+), 644 deletions(-) create mode 100644 collects/macro-debugger/syntax-browser/browser.ss 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/implementation.ss create mode 100644 collects/macro-debugger/syntax-browser/keymap.ss create mode 100644 collects/macro-debugger/syntax-browser/params.ss create mode 100644 collects/macro-debugger/syntax-browser/snipclass.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 44799d33d1..ccc0cde6a2 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/browser.ss b/collects/macro-debugger/syntax-browser/browser.ss new file mode 100644 index 0000000000..a2e99dbc54 --- /dev/null +++ b/collects/macro-debugger/syntax-browser/browser.ss @@ -0,0 +1,19 @@ + +(module browser mzscheme + (require (lib "unitsig.ss") + "interfaces.ss" + "frame.ss" + "implementation.ss") + (provide-signature-elements browser^) + (provide-signature-elements snip^) + + (define browser@ + (compound-unit/sig + (import) + (link [PREFS : prefs^ (global-prefs@)] + [IMPL : implementation^ (implementation@)] + [FRAME : browser^ (frame@ PREFS (IMPL widget))]) + (export (open FRAME)))) + + (define-values/invoke-unit/sig browser^ browser@) + ) diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index ac7f684eff..5f0d78dc2c 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 0000000000..176120bf05 --- /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 0000000000..12578406b7 --- /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/implementation.ss b/collects/macro-debugger/syntax-browser/implementation.ss new file mode 100644 index 0000000000..50c37f2d65 --- /dev/null +++ b/collects/macro-debugger/syntax-browser/implementation.ss @@ -0,0 +1,64 @@ + +(module implementation mzscheme + (require (lib "unitsig.ss") + "interfaces.ss" + "widget.ss" + "syntax-snip.ss" + "snipclass.ss" + "keymap.ss" + "prefs.ss") + (provide global-prefs@ + global-snip@ + implementation@) + (provide-signature-elements snip^) + (provide-signature-elements snipclass^) + + ;; prefs@ and snip@ should only be invoked once + ;; We create a new unit/sig out of their invocation + + (define snip-implementation@ + (compound-unit/sig + (import) + (link [PREFS : prefs^ (prefs@)] + [KEYMAP : keymap^ (keymap@)] + [MENU : context-menu^ (context-menu@ SNIP)] + [SNIP-CLASS : snipclass^ (snipclass@ SNIP)] + [SNIP-MENU : context-menu^ (snip-context-menu-extension@ MENU)] + [SNIP : snip^ (snip@ PREFS KEYMAP SNIP-MENU SNIP-CLASS)]) + (export (open PREFS) (open SNIP) (open SNIP-CLASS)))) + (define-values/invoke-unit/sig ((open snip^) (open prefs^) (open snipclass^)) + snip-implementation@) + + (define global-prefs@ + (unit/sig prefs^ + (import) + (rename (-width pref:width) + (-height pref:height) + (-props-percentage pref:props-percentage)) + (define -width pref:width) + (define -height pref:height) + (define -props-percentage pref:props-percentage))) + + (define global-snip@ + (unit/sig snip^ + (import) + (rename (-syntax-snip syntax-snip) + (-syntax-snip% syntax-snip%)) + (define -syntax-snip syntax-snip) + (define -syntax-snip% syntax-snip%))) + + ;; Everyone else re-uses the global-snip@ unit + + ;; implementation@ : prefs^ -> implementation^ + (define implementation@ + (compound-unit/sig + (import) + (link [KEYMAP : keymap^ (keymap@)] + [MENU : context-menu^ (context-menu@ SNIP)] + [SNIP : snip^ (global-snip@)] + [WIDGET-MENU : context-menu^ (widget-context-menu-extension@ MENU)] + [WIDGET : widget^ (widget@ KEYMAP WIDGET-MENU)]) + (export (unit SNIP snip) + (unit WIDGET widget)))) + + ) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index 9fa4eadeab..add1a86909 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 0000000000..14e6201541 --- /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/params.ss b/collects/macro-debugger/syntax-browser/params.ss new file mode 100644 index 0000000000..f952b87c76 --- /dev/null +++ b/collects/macro-debugger/syntax-browser/params.ss @@ -0,0 +1,13 @@ + +(module params mzscheme + (provide current-syntax-font-size + current-default-columns) + + ;; current-syntax-font-size : parameter of number/#f + ;; When non-false, overrides the default font size + (define current-syntax-font-size (make-parameter #f)) + + ;; current-default-columns : parameter of number + (define current-default-columns (make-parameter 60)) + + ) diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 0491dde6f5..944ec9ec6f 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 efd163284f..1cd5d369e1 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 23544ec1d1..00965ea336 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/snipclass.ss b/collects/macro-debugger/syntax-browser/snipclass.ss new file mode 100644 index 0000000000..50ac9b3e7b --- /dev/null +++ b/collects/macro-debugger/syntax-browser/snipclass.ss @@ -0,0 +1,84 @@ + +(module snipclass mzscheme + (require (lib "class.ss") + (lib "unitsig.ss") + (lib "mred.ss" "mred") + (lib "match.ss") + (lib "string.ss") + (lib "list.ss") + "interfaces.ss") + (provide snipclass@) + + (define snipclass@ + (unit/sig snipclass^ + (import snip^) + ;; 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 "implementation.ss" "macro-debugger" "syntax-browser"))) + (send (get-the-snip-class-list) add snip-class) + )) + + (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/syntax-browser.ss b/collects/macro-debugger/syntax-browser/syntax-browser.ss index 64cf44d83c..5ba5e069ef 100644 --- a/collects/macro-debugger/syntax-browser/syntax-browser.ss +++ b/collects/macro-debugger/syntax-browser/syntax-browser.ss @@ -1,29 +1,3 @@ (module syntax-browser mzscheme - (require (lib "class.ss") - "interfaces.ss" - "widget.ss") - (provide browse-syntax - browse-syntaxes - syntax-browser<%> - make-syntax-browser) - - ;; 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))) - ) diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index fbb78bea64..750f3f081c 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/typesetter.ss b/collects/macro-debugger/syntax-browser/typesetter.ss index f68074ca56..bfe7208c65 100644 --- a/collects/macro-debugger/syntax-browser/typesetter.ss +++ b/collects/macro-debugger/syntax-browser/typesetter.ss @@ -2,7 +2,7 @@ (module typesetter mzscheme (require (lib "class.ss") (lib "mred.ss" "mred") - "prefs.ss" + "params.ss" "pretty-range.ss" "pretty-printer.ss" "color.ss" diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 24831b0888..02ff0fd0a9 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/tool.ss b/collects/macro-debugger/tool.ss index 9a50e36a8f..f909a6618b 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -1,9 +1,5 @@ (module tool mzscheme - (require "model/trace.ss" - "model/hiding-policies.ss" - (prefix view: "view/gui.ss") - (prefix prefs: "syntax-browser/prefs.ss")) (require (lib "class.ss") (lib "list.ss") (lib "unitsig.ss") @@ -11,7 +7,11 @@ (lib "framework.ss" "framework") (lib "tool.ss" "drscheme") (lib "bitmap-label.ss" "mrlib") - (lib "string-constant.ss" "string-constants")) + (lib "string-constant.ss" "string-constants") + "model/trace.ss" + "model/hiding-policies.ss" + (prefix view: "view/gui.ss") + (prefix sb: "syntax-browser/embed.ss")) (define view-base/tool@ (unit/sig view:view-base^ @@ -22,8 +22,10 @@ (define-values/invoke-unit/sig view:view^ (compound-unit/sig (import) - (link (BASE : view:view-base^ (view-base/tool@)) - (VIEW : view:view^ (view:view@ BASE))) + (link (PREFS : sb:prefs^ (sb:global-prefs@)) + (SB : sb:implementation^ (sb:implementation@)) + (BASE : view:view-base^ (view-base/tool@)) + (VIEW : view:view^ (view:view@ BASE PREFS SB))) (export (open VIEW)))) (provide tool@) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index 8599054051..e5bbc500ab 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -6,10 +6,7 @@ (lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "boundmap.ss" "syntax") - (prefix sb: "../syntax-browser/syntax-browser.ss") - (prefix sb: "../syntax-browser/widget.ss") - (prefix sb: "../syntax-browser/prefs.ss") - (prefix sb: "../syntax-browser/partition.ss") + (prefix sb: "../syntax-browser/embed.ss") "../syntax-browser/util.ss" "../model/deriv.ss" "../model/deriv-util.ss" @@ -38,7 +35,6 @@ (define-signature view-base^ (base-frame%)) - ;; Configuration (define catch-errors? (make-parameter #f)) @@ -55,7 +51,9 @@ (define view@ (unit/sig view^ - (import view-base^) + (import view-base^ + (sb : sb:prefs^) + (sb : sb:implementation^)) (define macro-stepper-frame% (class base-frame% @@ -63,8 +61,8 @@ macro-hiding?) (init (show-hiding-panel? #t) (identifier=? "") - (width (sb:pref:width)) - (height (sb:pref:height))) + (width 700 #;(sb:pref:width)) + (height 500 #;(sb:pref:height))) (inherit get-menu% get-menu-item% get-menu-bar @@ -215,7 +213,9 @@ (stretchable-height #f) (alignment '(center center)))) - (define sbview (new sb:syntax-widget% (parent area))) + (define sbview (new sb:widget:syntax-widget% + (parent area) + (pref:props-percentage sb:pref:props-percentage))) (define sbc (send sbview get-controller)) (define control-pane (new vertical-panel% (parent area) (stretchable-height #f))) diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss new file mode 100644 index 0000000000..bf3f4bd7af --- /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 166e398c90..ee854d30fe 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 + )