diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 5650cab6..8e2b372f 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -1,8 +1,9 @@ (module framework mzscheme - (require (lib "unitsig.ss") - (lib "mred.ss" "mred") + (require (lib "unit.ss") + (lib "mred-unit.ss" "mred") (lib "mred-sig.ss" "mred") + (lib "mred.ss" "mred") (lib "class.ss") "test.ss" @@ -10,11 +11,38 @@ "decorated-editor-snip.ss" "framework-unit.ss" - "framework-sig.ss" + "private/sig.ss" (lib "contract.ss")) - (provide-signature-elements framework-class^) + (provide-signature-elements + (prefix application: framework:application-class^) + (prefix version: framework:version-class^) + (prefix color-model: framework:color-model-class^) + (prefix exn: framework:exn-class^) + (prefix mode: framework:mode-class^) + (prefix exit: framework:exit-class^) + (prefix menu: framework:menu-class^) + (prefix preferences: framework:preferences-class^) + (prefix number-snip: framework:number-snip-class^) + (prefix autosave: framework:autosave-class^) + (prefix path-utils: framework:path-utils-class^) + (prefix icon: framework:icon-class^) + (prefix keymap: framework:keymap-class^) + (prefix editor: framework:editor-class^) + (prefix pasteboard: framework:pasteboard-class^) + (prefix text: framework:text-class^) + (prefix color: framework:color-class^) + (prefix color-prefs: framework:color-prefs-class^) + (prefix comment-box: framework:comment-box-class^) + (prefix finder: framework:finder-class^) + (prefix group: framework:group-class^) + (prefix canvas: framework:canvas-class^) + (prefix panel: framework:panel-class^) + (prefix frame: framework:frame-class^) + (prefix handler: framework:handler-class^) + (prefix scheme: framework:scheme-class^) + (prefix main: framework:main-class^)) (provide (all-from "test.ss") (all-from "gui-utils.ss") @@ -27,13 +55,15 @@ (syntax-case stx () [(_ (name contract docs ...) ...) (syntax (provide/contract (name contract) ...))])) - - (define-values/invoke-unit/sig - framework^ - framework@ - #f - mred^) + + (define-compound-unit/infer framework+mred@ + (import) + (export framework^) + (link standard-mred@ framework@)) + + (define-values/invoke-unit/infer framework+mred@) + (provide/contract/docs (number-snip:make-repeating-decimal-snip diff --git a/collects/framework/private/application.ss b/collects/framework/private/application.ss index da32f122..ccad3e7e 100644 --- a/collects/framework/private/application.ss +++ b/collects/framework/private/application.ss @@ -1,18 +1,14 @@ -(module application mzscheme - (require (lib "unitsig.ss") - "sig.ss" - (lib "mred-sig.ss" "mred")) - - (provide application@) - - (define application@ - (unit/sig framework:application^ - (import) - - (define current-app-name (make-parameter - "MrEd" - (λ (x) - (unless (string? x) - (error 'current-app-name - "the app name must be a string")) - x)))))) \ No newline at end of file +(module application (lib "a-unit.ss") + (require "sig.ss") + + (import) + + (export framework:application^) + + (define current-app-name (make-parameter + "MrEd" + (λ (x) + (unless (string? x) + (error 'current-app-name + "the app name must be a string")) + x)))) \ No newline at end of file diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss index 01513a13..7aba4fdc 100644 --- a/collects/framework/private/autosave.ss +++ b/collects/framework/private/autosave.ss @@ -1,29 +1,27 @@ -(module autosave mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module autosave (lib "a-unit.ss") + (require (lib "class.ss") (lib "file.ss") "sig.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") (lib "mred.ss" "mred") ;; remove this! (lib "list.ss") - (lib "string-constant.ss" "string-constants")) - - (provide autosave@) + (lib "string-constant.ss" "string-constants") + (lib "unit.ss")) + + (import mred^ + [prefix exit: framework:exit^] + [prefix preferences: framework:preferences^] + [prefix frame: framework:frame^] + [prefix scheme: framework:scheme^] + [prefix editor: framework:editor^] + [prefix text: framework:text^] + [prefix finder: framework:finder^] + [prefix group: framework:group^]) + + (export framework:autosave^) - (define autosave@ - (unit/sig framework:autosave^ - (import mred^ - [exit : framework:exit^] - [preferences : framework:preferences^] - [frame : framework:frame^] - [scheme : framework:scheme^] - [editor : framework:editor^] - [text : framework:text^] - [finder : framework:finder^] - [group : framework:group^]) - (define autosavable<%> (interface () do-autosave)) @@ -316,4 +314,4 @@ (delete-file autosave-name) (when tmp-name (delete-file tmp-name)) - orig-name)))))))) + orig-name)))))) diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss index 63800e76..f3a1ed39 100644 --- a/collects/framework/private/canvas.ss +++ b/collects/framework/private/canvas.ss @@ -1,19 +1,15 @@ -(module canvas mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module canvas (lib "a-unit.ss") + (require (lib "class.ss") "sig.ss" (lib "mred-sig.ss" "mred")) - (provide canvas@) + (import mred^ + [prefix preferences: framework:preferences^] + [prefix frame: framework:frame^] + [prefix text: framework:text^]) - (define canvas@ - (unit/sig framework:canvas^ - (import mred^ - [preferences : framework:preferences^] - [frame : framework:frame^] - [text : framework:text^]) - - (rename [-color% color%]) + (export (rename framework:canvas^ + (-color% color%))) (define basic<%> (interface ((class->interface editor-canvas%)))) (define basic-mixin @@ -182,4 +178,4 @@ (define -color% (color-mixin basic%)) (define info% (info-mixin basic%)) (define delegate% (delegate-mixin basic%)) - (define wide-snip% (wide-snip-mixin basic%))))) + (define wide-snip% (wide-snip-mixin basic%))) diff --git a/collects/framework/private/color-model.ss b/collects/framework/private/color-model.ss index df0d4ddd..b38620f6 100644 --- a/collects/framework/private/color-model.ss +++ b/collects/framework/private/color-model.ss @@ -1,16 +1,11 @@ -(module color-model mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module color-model (lib "a-unit.ss") + (require (lib "class.ss") "sig.ss" (lib "mred-sig.ss" "mred") (lib "list.ss")) - (provide color-model@) - - (define color-model@ - (unit/sig framework:color-model^ - (import) - + (import) + (export framework:color-model^) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; matrix ops ;;; @@ -270,4 +265,4 @@ ;; (print-struct #t) ;; (xyz->luv (make-xyz 95.0 100.0 141.0)) ;; (xyz->luv (make-xyz 60.0 80.0 20.0)) - ))) \ No newline at end of file + ) \ No newline at end of file diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index 82525d2c..72e8e6ca 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -1,303 +1,296 @@ - -(module color-prefs mzscheme +(module color-prefs (lib "a-unit.ss") (require (lib "class.ss") - (lib "unitsig.ss") + (lib "unit.ss") (lib "etc.ss") (lib "mred.ss" "mred") (lib "string-constant.ss" "string-constants") "sig.ss") - - (provide color-prefs@) - (define sc-choose-color (string-constant syntax-coloring-choose-color)) + (import [prefix preferences: framework:preferences^] + [prefix editor: framework:editor^] + [prefix panel: framework:panel^] + [prefix canvas: framework:canvas^]) + (export framework:color-prefs^) + (init-depend framework:editor^) - (define color-prefs@ - (unit/sig framework:color-prefs^ - (import [preferences : framework:preferences^] - [editor : framework:editor^] - [panel : framework:panel^] - [canvas : framework:canvas^]) + (define standard-style-list-text% (editor:standard-style-list-mixin text%)) + + ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void + ;; constructs a panel containg controls to configure the preferences panel. + ;; BUG: style changes don't update the check boxes. + (define build-color-selection-panel + (opt-lambda (parent + pref-sym + style-name + example-text + [update-style-delta + (λ (func) + (let ([delta (preferences:get pref-sym)]) + (func delta) + (preferences:set pref-sym delta)))]) + (define hp (new horizontal-panel% + (parent parent) + (style '(border)) + (stretchable-height #f))) + (define e (new (class standard-style-list-text% + (inherit change-style get-style-list) + (define/augment (after-insert pos offset) + (inner (void) after-insert pos offset) + (let ([style (send (get-style-list) + find-named-style + style-name)]) + (change-style style pos (+ pos offset) #f))) + (super-new)))) + (define c (new canvas:color% + (parent hp) + (editor e) + (style '(hide-hscroll + hide-vscroll)))) - (define standard-style-list-text% (editor:standard-style-list-mixin text%)) + (define (make-check name on off) + (let* ([c (λ (check command) + (if (send check get-value) + (update-style-delta on) + (update-style-delta off)))] + [check (make-object check-box% name hp c)]) + check)) - ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void - ;; constructs a panel containg controls to configure the preferences panel. - ;; BUG: style changes don't update the check boxes. - (define build-color-selection-panel - (opt-lambda (parent - pref-sym - style-name - example-text - [update-style-delta - (λ (func) - (let ([delta (preferences:get pref-sym)]) - (func delta) - (preferences:set pref-sym delta)))]) - (define hp (new horizontal-panel% - (parent parent) - (style '(border)) - (stretchable-height #f))) - (define e (new (class standard-style-list-text% - (inherit change-style get-style-list) - (define/augment (after-insert pos offset) - (inner (void) after-insert pos offset) - (let ([style (send (get-style-list) - find-named-style - style-name)]) - (change-style style pos (+ pos offset) #f))) - (super-new)))) - (define c (new canvas:color% - (parent hp) - (editor e) - (style '(hide-hscroll - hide-vscroll)))) - - (define (make-check name on off) - (let* ([c (λ (check command) - (if (send check get-value) - (update-style-delta on) - (update-style-delta off)))] - [check (make-object check-box% name hp c)]) - check)) - - (define slant-check - (make-check (string-constant cs-italic) - (λ (delta) - (send delta set-style-on 'slant) - (send delta set-style-off 'base)) - (λ (delta) - (send delta set-style-on 'base) - (send delta set-style-off 'slant)))) - (define bold-check - (make-check (string-constant cs-bold) - (λ (delta) - (send delta set-weight-on 'bold) - (send delta set-weight-off 'base)) - (λ (delta) - (send delta set-weight-on 'base) - (send delta set-weight-off 'bold)))) - (define underline-check - (make-check (string-constant cs-underline) - (λ (delta) - (send delta set-underlined-on #t) - (send delta set-underlined-off #f)) - (λ (delta) - (send delta set-underlined-off #t) - (send delta set-underlined-on #f)))) - (define color-button - (and (>= (get-display-depth) 8) - (make-object button% - (string-constant cs-change-color) - hp - (λ (color-button evt) - (let* ([add (send (preferences:get pref-sym) get-foreground-add)] - [color (make-object color% - (send add get-r) - (send add get-g) - (send add get-b))] - [users-choice - (get-color-from-user - (format sc-choose-color example-text) - (send color-button get-top-level-window) - color)]) - (when users-choice - (update-style-delta - (λ (delta) - (send delta set-delta-foreground users-choice))))))))) - (define style (send (send e get-style-list) find-named-style style-name)) - - (send c set-line-count 1) - (send c allow-tab-exit #t) - - (send e insert example-text) - (send e set-position 0) - - (send slant-check set-value (eq? (send style get-style) 'slant)) - (send bold-check set-value (eq? (send style get-weight) 'bold)) - (send underline-check set-value (send style get-underlined)))) + (define slant-check + (make-check (string-constant cs-italic) + (λ (delta) + (send delta set-style-on 'slant) + (send delta set-style-off 'base)) + (λ (delta) + (send delta set-style-on 'base) + (send delta set-style-off 'slant)))) + (define bold-check + (make-check (string-constant cs-bold) + (λ (delta) + (send delta set-weight-on 'bold) + (send delta set-weight-off 'base)) + (λ (delta) + (send delta set-weight-on 'base) + (send delta set-weight-off 'bold)))) + (define underline-check + (make-check (string-constant cs-underline) + (λ (delta) + (send delta set-underlined-on #t) + (send delta set-underlined-off #f)) + (λ (delta) + (send delta set-underlined-off #t) + (send delta set-underlined-on #f)))) + (define color-button + (and (>= (get-display-depth) 8) + (make-object button% + (string-constant cs-change-color) + hp + (λ (color-button evt) + (let* ([add (send (preferences:get pref-sym) get-foreground-add)] + [color (make-object color% + (send add get-r) + (send add get-g) + (send add get-b))] + [users-choice + (get-color-from-user + (format (string-constant syntax-coloring-choose-color) example-text) + (send color-button get-top-level-window) + color)]) + (when users-choice + (update-style-delta + (λ (delta) + (send delta set-delta-foreground users-choice))))))))) + (define style (send (send e get-style-list) find-named-style style-name)) - (define (add/mult-set m v) - (send m set (car v) (cadr v) (caddr v))) + (send c set-line-count 1) + (send c allow-tab-exit #t) - (define (add/mult-get m) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)]) - (send m get b1 b2 b3) - (map unbox (list b1 b2 b3)))) + (send e insert example-text) + (send e set-position 0) - (define style-delta-get/set - (list (cons (λ (x) (send x get-alignment-off)) - (λ (x v) (send x set-alignment-off v))) - (cons (λ (x) (send x get-alignment-on)) - (λ (x v) (send x set-alignment-on v))) - (cons (λ (x) (add/mult-get (send x get-background-add))) - (λ (x v) (add/mult-set (send x get-background-add) v))) - (cons (λ (x) (add/mult-get (send x get-background-mult))) - (λ (x v) (add/mult-set (send x get-background-mult) v))) - (cons (λ (x) (send x get-face)) - (λ (x v) (send x set-face v))) - (cons (λ (x) (send x get-family)) - (λ (x v) (send x set-family v))) - (cons (λ (x) (add/mult-get (send x get-foreground-add))) - (λ (x v) (add/mult-set (send x get-foreground-add) v))) - (cons (λ (x) (add/mult-get (send x get-foreground-mult))) - (λ (x v) (add/mult-set (send x get-foreground-mult) v))) - (cons (λ (x) (send x get-size-add)) - (λ (x v) (send x set-size-add v))) - (cons (λ (x) (send x get-size-mult)) - (λ (x v) (send x set-size-mult v))) - (cons (λ (x) (send x get-style-off)) - (λ (x v) (send x set-style-off v))) - (cons (λ (x) (send x get-style-on)) - (λ (x v) (send x set-style-on v))) - (cons (λ (x) (send x get-underlined-off)) - (λ (x v) (send x set-underlined-off v))) - (cons (λ (x) (send x get-underlined-on)) - (λ (x v) (send x set-underlined-on v))) - (cons (λ (x) (send x get-weight-off)) - (λ (x v) (send x set-weight-off v))) - (cons (λ (x) (send x get-weight-on)) - (λ (x v) (send x set-weight-on v))))) - - (define (marshall-style style) - (map (λ (fs) ((car fs) style)) style-delta-get/set)) - - (define (unmarshall-style info) - (let ([style (make-object style-delta%)]) - (for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info) - style)) - - (define (make-style-delta color bold? underline? italic?) - (let ((sd (make-object style-delta%))) - (send sd set-delta-foreground color) - (cond - (bold? - (send sd set-weight-on 'bold) - (send sd set-weight-off 'base)) - (else - (send sd set-weight-on 'base) - (send sd set-weight-off 'bold))) - (send sd set-underlined-on underline?) - (send sd set-underlined-off (not underline?)) - (cond - (italic? - (send sd set-style-on 'italic) - (send sd set-style-off 'base)) - (else - (send sd set-style-on 'base) - (send sd set-style-off 'italic))) - sd)) - - (define (add-background-preferences-panel) - (preferences:add-panel - (list (string-constant preferences-colors) - (string-constant background-color)) - (λ (parent) - (let ([vp (new vertical-panel% (parent parent))]) - (add-solid-color-config (string-constant background-color) - vp - 'framework:basic-canvas-background) - (add-solid-color-config (string-constant paren-match-color) - vp - 'framework:paren-match-color) - (build-text-foreground-selection-panel vp - 'framework:default-text-color - (editor:get-default-color-style-name) - (string-constant default-text-color)))))) - - (define (build-text-foreground-selection-panel parent pref-sym style-name example-text) - (define hp (new horizontal-panel% - (parent parent) - (style '(border)) - (stretchable-height #f))) - (define e (new (class standard-style-list-text% - (inherit change-style get-style-list) - (define/augment (after-insert pos offset) - (inner (void) after-insert pos offset) - (let ([style (send (get-style-list) - find-named-style - style-name)]) - (change-style style pos (+ pos offset) #f))) - (super-new)))) - (define c (new canvas:color% - (parent hp) - (editor e) - (style '(hide-hscroll - hide-vscroll)))) - (define color-button - (and (>= (get-display-depth) 8) - (make-object button% - (string-constant cs-change-color) - hp - (λ (color-button evt) - (let ([users-choice - (get-color-from-user - (format sc-choose-color example-text) - (send color-button get-top-level-window) - (preferences:get pref-sym))]) - (when users-choice - (preferences:set pref-sym users-choice))))))) - (define style (send (send e get-style-list) find-named-style style-name)) - - (send c set-line-count 1) - (send c allow-tab-exit #t) - - (send e insert example-text) - (send e set-position 0)) - - (define (add-solid-color-config label parent pref-id) - (letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))] - [hp (new horizontal-panel% (parent panel) (stretchable-height #f))] - [msg (new message% (parent hp) (label label))] - [canvas - (new canvas% - (parent hp) - (paint-callback - (λ (c dc) - (draw (preferences:get pref-id)))))] - [draw - (λ (clr) - (let ([dc (send canvas get-dc)]) - (let-values ([(w h) (send canvas get-client-size)]) - (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid)) - (send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid)) - (send dc draw-rectangle 0 0 w h))))] - [button - (new button% - (label (string-constant cs-change-color)) - (parent hp) - (callback - (λ (x y) - (let ([color (get-color-from-user - (string-constant choose-a-background-color) - (send hp get-top-level-window) - (preferences:get pref-id))]) - (when color - (preferences:set pref-id color))))))]) - (preferences:add-callback - pref-id - (λ (p v) (draw v))) - panel)) - - ;; add-to-preferences-panel : string (vertical-panel -> void) -> void - (define (add-to-preferences-panel panel-name func) - (preferences:add-panel - (list (string-constant preferences-colors) panel-name) - (λ (parent) - (let ([panel (new vertical-panel% (parent parent))]) - (func panel) - panel)))) - - ;; see docs - (define (register-color-pref pref-name style-name color) - (let ([sd (new style-delta%)]) - (send sd set-delta-foreground color) - (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%)))) - (preferences:set-un/marshall pref-name marshall-style unmarshall-style) - (preferences:add-callback pref-name - (λ (sym v) - (editor:set-standard-style-list-delta style-name v))) - (editor:set-standard-style-list-delta style-name (preferences:get pref-name)))))) - - + (send slant-check set-value (eq? (send style get-style) 'slant)) + (send bold-check set-value (eq? (send style get-weight) 'bold)) + (send underline-check set-value (send style get-underlined)))) + + (define (add/mult-set m v) + (send m set (car v) (cadr v) (caddr v))) + + (define (add/mult-get m) + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)]) + (send m get b1 b2 b3) + (map unbox (list b1 b2 b3)))) + + (define style-delta-get/set + (list (cons (λ (x) (send x get-alignment-off)) + (λ (x v) (send x set-alignment-off v))) + (cons (λ (x) (send x get-alignment-on)) + (λ (x v) (send x set-alignment-on v))) + (cons (λ (x) (add/mult-get (send x get-background-add))) + (λ (x v) (add/mult-set (send x get-background-add) v))) + (cons (λ (x) (add/mult-get (send x get-background-mult))) + (λ (x v) (add/mult-set (send x get-background-mult) v))) + (cons (λ (x) (send x get-face)) + (λ (x v) (send x set-face v))) + (cons (λ (x) (send x get-family)) + (λ (x v) (send x set-family v))) + (cons (λ (x) (add/mult-get (send x get-foreground-add))) + (λ (x v) (add/mult-set (send x get-foreground-add) v))) + (cons (λ (x) (add/mult-get (send x get-foreground-mult))) + (λ (x v) (add/mult-set (send x get-foreground-mult) v))) + (cons (λ (x) (send x get-size-add)) + (λ (x v) (send x set-size-add v))) + (cons (λ (x) (send x get-size-mult)) + (λ (x v) (send x set-size-mult v))) + (cons (λ (x) (send x get-style-off)) + (λ (x v) (send x set-style-off v))) + (cons (λ (x) (send x get-style-on)) + (λ (x v) (send x set-style-on v))) + (cons (λ (x) (send x get-underlined-off)) + (λ (x v) (send x set-underlined-off v))) + (cons (λ (x) (send x get-underlined-on)) + (λ (x v) (send x set-underlined-on v))) + (cons (λ (x) (send x get-weight-off)) + (λ (x v) (send x set-weight-off v))) + (cons (λ (x) (send x get-weight-on)) + (λ (x v) (send x set-weight-on v))))) + + (define (marshall-style style) + (map (λ (fs) ((car fs) style)) style-delta-get/set)) + + (define (unmarshall-style info) + (let ([style (make-object style-delta%)]) + (for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info) + style)) + + (define (make-style-delta color bold? underline? italic?) + (let ((sd (make-object style-delta%))) + (send sd set-delta-foreground color) + (cond + (bold? + (send sd set-weight-on 'bold) + (send sd set-weight-off 'base)) + (else + (send sd set-weight-on 'base) + (send sd set-weight-off 'bold))) + (send sd set-underlined-on underline?) + (send sd set-underlined-off (not underline?)) + (cond + (italic? + (send sd set-style-on 'italic) + (send sd set-style-off 'base)) + (else + (send sd set-style-on 'base) + (send sd set-style-off 'italic))) + sd)) + + (define (add-background-preferences-panel) + (preferences:add-panel + (list (string-constant preferences-colors) + (string-constant background-color)) + (λ (parent) + (let ([vp (new vertical-panel% (parent parent))]) + (add-solid-color-config (string-constant background-color) + vp + 'framework:basic-canvas-background) + (add-solid-color-config (string-constant paren-match-color) + vp + 'framework:paren-match-color) + (build-text-foreground-selection-panel vp + 'framework:default-text-color + (editor:get-default-color-style-name) + (string-constant default-text-color)))))) + + (define (build-text-foreground-selection-panel parent pref-sym style-name example-text) + (define hp (new horizontal-panel% + (parent parent) + (style '(border)) + (stretchable-height #f))) + (define e (new (class standard-style-list-text% + (inherit change-style get-style-list) + (define/augment (after-insert pos offset) + (inner (void) after-insert pos offset) + (let ([style (send (get-style-list) + find-named-style + style-name)]) + (change-style style pos (+ pos offset) #f))) + (super-new)))) + (define c (new canvas:color% + (parent hp) + (editor e) + (style '(hide-hscroll + hide-vscroll)))) + (define color-button + (and (>= (get-display-depth) 8) + (make-object button% + (string-constant cs-change-color) + hp + (λ (color-button evt) + (let ([users-choice + (get-color-from-user + (format (string-constant syntax-coloring-choose-color) example-text) + (send color-button get-top-level-window) + (preferences:get pref-sym))]) + (when users-choice + (preferences:set pref-sym users-choice))))))) + (define style (send (send e get-style-list) find-named-style style-name)) + + (send c set-line-count 1) + (send c allow-tab-exit #t) + + (send e insert example-text) + (send e set-position 0)) + + (define (add-solid-color-config label parent pref-id) + (letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))] + [hp (new horizontal-panel% (parent panel) (stretchable-height #f))] + [msg (new message% (parent hp) (label label))] + [canvas + (new canvas% + (parent hp) + (paint-callback + (λ (c dc) + (draw (preferences:get pref-id)))))] + [draw + (λ (clr) + (let ([dc (send canvas get-dc)]) + (let-values ([(w h) (send canvas get-client-size)]) + (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid)) + (send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid)) + (send dc draw-rectangle 0 0 w h))))] + [button + (new button% + (label (string-constant cs-change-color)) + (parent hp) + (callback + (λ (x y) + (let ([color (get-color-from-user + (string-constant choose-a-background-color) + (send hp get-top-level-window) + (preferences:get pref-id))]) + (when color + (preferences:set pref-id color))))))]) + (preferences:add-callback + pref-id + (λ (p v) (draw v))) + panel)) + + ;; add-to-preferences-panel : string (vertical-panel -> void) -> void + (define (add-to-preferences-panel panel-name func) + (preferences:add-panel + (list (string-constant preferences-colors) panel-name) + (λ (parent) + (let ([panel (new vertical-panel% (parent parent))]) + (func panel) + panel)))) + + ;; see docs + (define (register-color-pref pref-name style-name color) + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground color) + (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%)))) + (preferences:set-un/marshall pref-name marshall-style unmarshall-style) + (preferences:add-callback pref-name + (λ (sym v) + (editor:set-standard-style-list-delta style-name v))) + (editor:set-standard-style-list-delta style-name (preferences:get pref-name)))) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 5cf75d86..23d3ff15 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -1,732 +1,728 @@ -(module color mzscheme +(module color (lib "a-unit.ss") (require (lib "class.ss") (lib "etc.ss") - (lib "unitsig.ss") (lib "thread.ss") (lib "mred.ss" "mred") (lib "token-tree.ss" "syntax-color") (lib "paren-tree.ss" "syntax-color") (lib "default-lexer.ss" "syntax-color") + (lib "unit.ss") "sig.ss") - - (define original-output-port (current-output-port)) - (define (oprintf . args) (apply fprintf original-output-port args)) + + (import [prefix preferences: framework:preferences^] + [prefix icon: framework:icon^] + [prefix mode: framework:mode^] + [prefix text: framework:text^] + [prefix color-prefs: framework:color-prefs^] + [prefix scheme: framework:scheme^]) + + (export (rename framework:color^ + (-text<%> text<%>) + (-text% text%) + (-text-mode<%> text-mode<%>))) + + (init-depend framework:text^ framework:mode^) - (provide color@) - (define (should-color-type? type) (not (memq type '(white-space no-color)))) - (define color@ - (unit/sig framework:color^ - (import [preferences : framework:preferences^] - [icon : framework:icon^] - [mode : framework:mode^] - [text : framework:text^] - [color-prefs : framework:color-prefs^] - [scheme : framework:scheme^]) - - (rename [-text<%> text<%>] - [-text% text%] - [-text-mode<%> text-mode<%>]) + (define -text<%> + (interface (text:basic<%>) + start-colorer + stop-colorer + force-stop-colorer - (define -text<%> - (interface (text:basic<%>) - start-colorer - stop-colorer - force-stop-colorer - - is-stopped? - is-frozen? - freeze-colorer - thaw-colorer - - reset-region - update-region-end - - skip-whitespace - backward-match - backward-containing-sexp - forward-match - insert-close-paren - classify-position)) - - (define text-mixin - (mixin (text:basic<%>) (-text<%>) - - ;; For profiling - (define timer #f) - - ;; ---------------------- Coloring modes ---------------------------- - - ;; The tokenizer is stopped. This is used by the surrogate to enter - ;; a mode with no coloring or paren matching. - (define stopped? #t) - - ;; The tokenizer is stopped and prevented from starting. This is - ;; an internal call for debugging. - (define force-stop? #f) - - ;; color-callback has been suspended because the text% became locked - ;; and should be requeued when the text% is unlocked. - (define restart-callback #f) - - ;; Some other tool wants to take over coloring the buffer, so the - ;; colorer shouldn't color anything. - (define frozen? #f) - ;; true iff the colorer must recolor from scratch when the freeze - ;; is over. - (define force-recolor-after-freeze #f) - - ;; ---------------------- Lexing state ------------------------------ - - ;; The tree of valid tokens, starting at start-pos - (define tokens (new token-tree%)) - - ;; If the tree is completed - (define up-to-date? #t) - (define/public (get-up-to-date?) up-to-date?) - - ;; The tree of tokens that have been invalidated by an edit - ;; but might still be valid. - (define invalid-tokens (new token-tree%)) - - ;; The position right before the invalid-tokens tree - (define invalid-tokens-start +inf.0) - - ;; The position right before the next token to be read - (define current-pos start-pos) - - ;; The lexer - (define get-token #f) - - ;; ---------------------- Parenethesis matching ---------------------- - - ;; The pairs of matching parens - (define pairs '()) - (define parens (new paren-tree% (matches pairs))) - - - ;; ---------------------- Interactions state ------------------------ - ;; The positions right before and right after the area to be tokenized - (define start-pos 0) - (define end-pos 'end) - - (inherit last-position) - - ;; See docs - (define/public (reset-region start end) - (unless (and (= start start-pos) (eqv? end end-pos)) - (unless (<= 0 start (last-position)) - (raise-mismatch-error 'reset-region - "start position not inside editor: " - start)) - (unless (or (eq? 'end end) (<= 0 end (last-position))) - (raise-mismatch-error 'reset-region - "end position not inside editor: " - end)) - (unless (or (eq? 'end end) (<= start end)) - (raise-mismatch-error 'reset-region - "end position before start position: " - (list end start))) - (set! start-pos start) - (set! end-pos end) - (reset-tokens) - (do-insert/delete start 0))) - - (define/public (get-region) (values start-pos end-pos)) - - ;; Modify the end of the region. - (define/public (update-region-end end) - (set! end-pos end)) - - ;; ---------------------- Preferences ------------------------------- - (define should-color? #t) - (define token-sym->style #f) - - ;; ---------------------- Multi-threading --------------------------- - ;; A list of thunks that color the buffer - (define colors null) - ;; The coroutine object for tokenizing the buffer - (define tok-cor #f) - ;; The editor revision when tok-cor was created - (define rev #f) - - - (inherit change-style begin-edit-sequence end-edit-sequence highlight-range - get-style-list in-edit-sequence? get-start-position get-end-position - local-edit-sequence? get-styles-fixed has-focus? - get-fixed-style) - - (define/private (reset-tokens) - (send tokens reset-tree) - (send invalid-tokens reset-tree) - (set! invalid-tokens-start +inf.0) - (set! up-to-date? #t) - (set! restart-callback #f) - (set! force-recolor-after-freeze #f) - (set! parens (new paren-tree% (matches pairs))) - (set! current-pos start-pos) - (set! colors null) + is-stopped? + is-frozen? + freeze-colorer + thaw-colorer + + reset-region + update-region-end + + skip-whitespace + backward-match + backward-containing-sexp + forward-match + insert-close-paren + classify-position)) + + (define text-mixin + (mixin (text:basic<%>) (-text<%>) + + ;; For profiling + (define timer #f) + + ;; ---------------------- Coloring modes ---------------------------- + + ;; The tokenizer is stopped. This is used by the surrogate to enter + ;; a mode with no coloring or paren matching. + (define stopped? #t) + + ;; The tokenizer is stopped and prevented from starting. This is + ;; an internal call for debugging. + (define force-stop? #f) + + ;; color-callback has been suspended because the text% became locked + ;; and should be requeued when the text% is unlocked. + (define restart-callback #f) + + ;; Some other tool wants to take over coloring the buffer, so the + ;; colorer shouldn't color anything. + (define frozen? #f) + ;; true iff the colorer must recolor from scratch when the freeze + ;; is over. + (define force-recolor-after-freeze #f) + + ;; ---------------------- Lexing state ------------------------------ + + ;; The tree of valid tokens, starting at start-pos + (define tokens (new token-tree%)) + + ;; If the tree is completed + (define up-to-date? #t) + (define/public (get-up-to-date?) up-to-date?) + + ;; The tree of tokens that have been invalidated by an edit + ;; but might still be valid. + (define invalid-tokens (new token-tree%)) + + ;; The position right before the invalid-tokens tree + (define invalid-tokens-start +inf.0) + + ;; The position right before the next token to be read + (define current-pos start-pos) + + ;; The lexer + (define get-token #f) + + ;; ---------------------- Parenethesis matching ---------------------- + + ;; The pairs of matching parens + (define pairs '()) + (define parens (new paren-tree% (matches pairs))) + + + ;; ---------------------- Interactions state ------------------------ + ;; The positions right before and right after the area to be tokenized + (define start-pos 0) + (define end-pos 'end) + + (inherit last-position) + + ;; See docs + (define/public (reset-region start end) + (unless (and (= start start-pos) (eqv? end end-pos)) + (unless (<= 0 start (last-position)) + (raise-mismatch-error 'reset-region + "start position not inside editor: " + start)) + (unless (or (eq? 'end end) (<= 0 end (last-position))) + (raise-mismatch-error 'reset-region + "end position not inside editor: " + end)) + (unless (or (eq? 'end end) (<= start end)) + (raise-mismatch-error 'reset-region + "end position before start position: " + (list end start))) + (set! start-pos start) + (set! end-pos end) + (reset-tokens) + (do-insert/delete start 0))) + + (define/public (get-region) (values start-pos end-pos)) + + ;; Modify the end of the region. + (define/public (update-region-end end) + (set! end-pos end)) + + ;; ---------------------- Preferences ------------------------------- + (define should-color? #t) + (define token-sym->style #f) + + ;; ---------------------- Multi-threading --------------------------- + ;; A list of thunks that color the buffer + (define colors null) + ;; The coroutine object for tokenizing the buffer + (define tok-cor #f) + ;; The editor revision when tok-cor was created + (define rev #f) + + + (inherit change-style begin-edit-sequence end-edit-sequence highlight-range + get-style-list in-edit-sequence? get-start-position get-end-position + local-edit-sequence? get-styles-fixed has-focus? + get-fixed-style) + + (define/private (reset-tokens) + (send tokens reset-tree) + (send invalid-tokens reset-tree) + (set! invalid-tokens-start +inf.0) + (set! up-to-date? #t) + (set! restart-callback #f) + (set! force-recolor-after-freeze #f) + (set! parens (new paren-tree% (matches pairs))) + (set! current-pos start-pos) + (set! colors null) + (when tok-cor + (coroutine-kill tok-cor)) + (set! tok-cor #f) + (set! rev #f)) + + ;; Actually color the buffer. + (define/private (color) + (unless (null? colors) + ((car colors)) + (set! colors (cdr colors)) + (color))) + + ;; Discard extra tokens at the first of invalid-tokens + (define/private (sync-invalid) + (when (and (not (send invalid-tokens is-empty?)) + (< invalid-tokens-start current-pos)) + (send invalid-tokens search-min!) + (let ((length (send invalid-tokens get-root-length))) + (send invalid-tokens remove-root!) + (set! invalid-tokens-start (+ invalid-tokens-start length))) + (sync-invalid))) + + (define/private (re-tokenize in in-start-pos enable-suspend) + (let-values ([(lexeme type data new-token-start new-token-end) + (get-token in)]) + (unless (eq? 'eof type) + (enable-suspend #f) + #;(printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) + (+ in-start-pos (sub1 new-token-end))) + (let ((len (- new-token-end new-token-start))) + (set! current-pos (+ len current-pos)) + (sync-invalid) + (when (and should-color? (should-color-type? type) (not frozen?)) + (set! colors + (cons + (let* ([style-name (token-sym->style type)] + (color (send (get-style-list) find-named-style style-name)) + (sp (+ in-start-pos (sub1 new-token-start))) + (ep (+ in-start-pos (sub1 new-token-end)))) + (λ () + (change-style color sp ep #f))) + colors))) + ; Using the non-spec version takes 3 times as long as the spec + ; version. In other words, the new greatly outweighs the tree + ; operations. + ;(insert-last! tokens (new token-tree% (length len) (data type))) + (insert-last-spec! tokens len type) + (send parens add-token data len) + (cond + ((and (not (send invalid-tokens is-empty?)) + (= invalid-tokens-start current-pos)) + (send invalid-tokens search-max!) + (send parens merge-tree + (send invalid-tokens get-root-end-position)) + (insert-last! tokens invalid-tokens) + (set! invalid-tokens-start +inf.0) + (enable-suspend #t)) + (else + (enable-suspend #t) + (re-tokenize in in-start-pos enable-suspend))))))) + + (define/private (do-insert/delete edit-start-pos change-length) + (unless (or stopped? force-stop?) + (unless up-to-date? + (sync-invalid)) + (cond + (up-to-date? + (let-values + (((orig-token-start orig-token-end valid-tree invalid-tree) + (send tokens split (- edit-start-pos start-pos)))) + (send parens split-tree orig-token-start) + (set! invalid-tokens invalid-tree) + (set! tokens valid-tree) + (set! invalid-tokens-start + (if (send invalid-tokens is-empty?) + +inf.0 + (+ start-pos orig-token-end change-length))) + (set! current-pos (+ start-pos orig-token-start)) + (set! up-to-date? #f) + (queue-callback (λ () (colorer-callback)) #f))) + ((>= edit-start-pos invalid-tokens-start) + (let-values (((tok-start tok-end valid-tree invalid-tree) + (send invalid-tokens split (- edit-start-pos start-pos)))) + (set! invalid-tokens invalid-tree) + (set! invalid-tokens-start + (+ invalid-tokens-start tok-end change-length)))) + ((> edit-start-pos current-pos) + (set! invalid-tokens-start (+ change-length invalid-tokens-start))) + (else + (let-values (((tok-start tok-end valid-tree invalid-tree) + (send tokens split (- edit-start-pos start-pos)))) + (send parens truncate tok-start) + (set! tokens valid-tree) + (set! invalid-tokens-start (+ change-length invalid-tokens-start)) + (set! current-pos (+ start-pos tok-start))))))) + + (inherit is-locked? get-revision-number) + + (define/private (colorer-driver) + (unless up-to-date? + #;(printf "revision ~a~n" (get-revision-number)) + (unless (and tok-cor (= rev (get-revision-number))) (when tok-cor (coroutine-kill tok-cor)) - (set! tok-cor #f) - (set! rev #f)) - - ;; Actually color the buffer. - (define/private (color) - (unless (null? colors) - ((car colors)) - (set! colors (cdr colors)) - (color))) - - ;; Discard extra tokens at the first of invalid-tokens - (define/private (sync-invalid) - (when (and (not (send invalid-tokens is-empty?)) - (< invalid-tokens-start current-pos)) - (send invalid-tokens search-min!) - (let ((length (send invalid-tokens get-root-length))) - (send invalid-tokens remove-root!) - (set! invalid-tokens-start (+ invalid-tokens-start length))) - (sync-invalid))) - - (define/private (re-tokenize in in-start-pos enable-suspend) - (let-values ([(lexeme type data new-token-start new-token-end) - (get-token in)]) - (unless (eq? 'eof type) - (enable-suspend #f) - #;(printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) - (+ in-start-pos (sub1 new-token-end))) - (let ((len (- new-token-end new-token-start))) - (set! current-pos (+ len current-pos)) - (sync-invalid) - (when (and should-color? (should-color-type? type) (not frozen?)) - (set! colors - (cons - (let* ([style-name (token-sym->style type)] - (color (send (get-style-list) find-named-style style-name)) - (sp (+ in-start-pos (sub1 new-token-start))) - (ep (+ in-start-pos (sub1 new-token-end)))) - (λ () - (change-style color sp ep #f))) - colors))) - ; Using the non-spec version takes 3 times as long as the spec - ; version. In other words, the new greatly outweighs the tree - ; operations. - ;(insert-last! tokens (new token-tree% (length len) (data type))) - (insert-last-spec! tokens len type) - (send parens add-token data len) - (cond - ((and (not (send invalid-tokens is-empty?)) - (= invalid-tokens-start current-pos)) - (send invalid-tokens search-max!) - (send parens merge-tree - (send invalid-tokens get-root-end-position)) - (insert-last! tokens invalid-tokens) - (set! invalid-tokens-start +inf.0) - (enable-suspend #t)) - (else - (enable-suspend #t) - (re-tokenize in in-start-pos enable-suspend))))))) - - (define/private (do-insert/delete edit-start-pos change-length) - (unless (or stopped? force-stop?) - (unless up-to-date? - (sync-invalid)) - (cond - (up-to-date? - (let-values - (((orig-token-start orig-token-end valid-tree invalid-tree) - (send tokens split (- edit-start-pos start-pos)))) - (send parens split-tree orig-token-start) - (set! invalid-tokens invalid-tree) - (set! tokens valid-tree) - (set! invalid-tokens-start - (if (send invalid-tokens is-empty?) - +inf.0 - (+ start-pos orig-token-end change-length))) - (set! current-pos (+ start-pos orig-token-start)) - (set! up-to-date? #f) - (queue-callback (λ () (colorer-callback)) #f))) - ((>= edit-start-pos invalid-tokens-start) - (let-values (((tok-start tok-end valid-tree invalid-tree) - (send invalid-tokens split (- edit-start-pos start-pos)))) - (set! invalid-tokens invalid-tree) - (set! invalid-tokens-start - (+ invalid-tokens-start tok-end change-length)))) - ((> edit-start-pos current-pos) - (set! invalid-tokens-start (+ change-length invalid-tokens-start))) - (else - (let-values (((tok-start tok-end valid-tree invalid-tree) - (send tokens split (- edit-start-pos start-pos)))) - (send parens truncate tok-start) - (set! tokens valid-tree) - (set! invalid-tokens-start (+ change-length invalid-tokens-start)) - (set! current-pos (+ start-pos tok-start))))))) - - (inherit is-locked? get-revision-number) - - (define/private (colorer-driver) + #;(printf "new coroutine~n") + (set! tok-cor + (coroutine + (λ (enable-suspend) + (parameterize ((port-count-lines-enabled #t)) + (re-tokenize (open-input-text-editor this current-pos end-pos + (λ (x) #f)) + current-pos + enable-suspend))))) + (set! rev (get-revision-number))) + (with-handlers ((exn:fail? + (λ (exn) + (parameterize ((print-struct #t)) + ((error-display-handler) + (format "exception in colorer thread: ~s" exn) + exn)) + (set! tok-cor #f)))) + #;(printf "begin lexing~n") + (when (coroutine-run 10 tok-cor) + (set! up-to-date? #t))) + #;(printf "end lexing~n") + #;(printf "begin coloring~n") + ;; This edit sequence needs to happen even when colors is null + ;; for the paren highlighter. + (begin-edit-sequence #f #f) + (color) + (end-edit-sequence) + #;(printf "end coloring~n"))) + + (define/private (colorer-callback) + (cond + ((is-locked?) + (set! restart-callback #t)) + (else + (unless (in-edit-sequence?) + (colorer-driver)) + (unless up-to-date? + (queue-callback (λ () (colorer-callback)) #f))))) + + ;; Must not be called when the editor is locked + (define/private (finish-now) + (unless stopped? + (let loop () (unless up-to-date? - #;(printf "revision ~a~n" (get-revision-number)) - (unless (and tok-cor (= rev (get-revision-number))) - (when tok-cor - (coroutine-kill tok-cor)) - #;(printf "new coroutine~n") - (set! tok-cor - (coroutine - (λ (enable-suspend) - (parameterize ((port-count-lines-enabled #t)) - (re-tokenize (open-input-text-editor this current-pos end-pos - (λ (x) #f)) - current-pos - enable-suspend))))) - (set! rev (get-revision-number))) - (with-handlers ((exn:fail? - (λ (exn) - (parameterize ((print-struct #t)) - ((error-display-handler) - (format "exception in colorer thread: ~s" exn) - exn)) - (set! tok-cor #f)))) - #;(printf "begin lexing~n") - (when (coroutine-run 10 tok-cor) - (set! up-to-date? #t))) - #;(printf "end lexing~n") - #;(printf "begin coloring~n") - ;; This edit sequence needs to happen even when colors is null - ;; for the paren highlighter. - (begin-edit-sequence #f #f) - (color) - (end-edit-sequence) - #;(printf "end coloring~n"))) - - (define/private (colorer-callback) - (cond - ((is-locked?) - (set! restart-callback #t)) - (else - (unless (in-edit-sequence?) - (colorer-driver)) - (unless up-to-date? - (queue-callback (λ () (colorer-callback)) #f))))) - - ;; Must not be called when the editor is locked - (define/private (finish-now) - (unless stopped? - (let loop () - (unless up-to-date? - (colorer-driver) - (loop))))) - - ;; See docs - (define/public (start-colorer token-sym->style- get-token- pairs-) - (unless force-stop? - (set! stopped? #f) - (reset-tokens) - (set! should-color? (preferences:get 'framework:coloring-active)) - (set! token-sym->style token-sym->style-) - (set! get-token get-token-) - (set! pairs pairs-) - (set! parens (new paren-tree% (matches pairs))) - ;; (set! timer (current-milliseconds)) - (do-insert/delete start-pos 0))) - - ;; See docs - (define/public stop-colorer - (opt-lambda ((clear-colors #t)) - (set! stopped? #t) - (when (and clear-colors (not frozen?)) - (begin-edit-sequence #f #f) - (change-style (get-fixed-style) start-pos end-pos #f) - (end-edit-sequence)) - (match-parens #t) - (reset-tokens) - (set! pairs null) - (set! token-sym->style #f) - (set! get-token #f))) - - (define/public (is-frozen?) frozen?) - (define/public (is-stopped?) stopped?) - - ;; See docs - (define/public (freeze-colorer) - (when (is-locked?) - (error 'freeze-colorer "called on a locked color:text<%>.")) - (unless frozen? - (finish-now) - (set! frozen? #t))) - - ;; See docs - (define/public thaw-colorer - (opt-lambda ((recolor? #t) - (retokenize? #f)) - (when frozen? - (set! frozen? #f) - (cond - (stopped? - (stop-colorer)) - ((or force-recolor-after-freeze recolor?) - (cond - (retokenize? - (let ((tn token-sym->style) - (gt get-token) - (p pairs)) - (stop-colorer (not should-color?)) - (start-colorer tn gt p))) - (else - (begin-edit-sequence #f #f) - (finish-now) - (send tokens for-each - (λ (start len type) - (when (and should-color? (should-color-type? type)) - (let ((color (send (get-style-list) find-named-style - (token-sym->style type))) - (sp (+ start-pos start)) - (ep (+ start-pos (+ start len)))) - (change-style color sp ep #f))))) - (end-edit-sequence)))))))) - - - (define/private (toggle-color on?) - (cond - ((and frozen? (not (equal? on? should-color?))) - (set! should-color? on?) - (set! force-recolor-after-freeze #t)) - ((and (not should-color?) on?) - (set! should-color? on?) - (reset-tokens) - (do-insert/delete start-pos 0)) - ((and should-color? (not on?)) - (set! should-color? on?) - (begin-edit-sequence #f #f) - (change-style (get-fixed-style) start-pos end-pos #f) - (end-edit-sequence)))) - - ;; see docs - (define/public (force-stop-colorer stop?) - (set! force-stop? stop?) - (when stop? - (stop-colorer))) - - - ;; ----------------------- Match parentheses ---------------------------- - - (define clear-old-locations void) - - (define mismatch-color (make-object color% "PINK")) - (define/private (get-match-color) (preferences:get 'framework:paren-match-color)) - - (define/private (highlight start end caret-pos error?) - (let ([off (highlight-range (+ start-pos start) (+ start-pos end) - (if error? mismatch-color (get-match-color)) - (and (send (icon:get-paren-highlight-bitmap) - ok?) - (icon:get-paren-highlight-bitmap)) - (= caret-pos (+ start-pos start)))]) - (set! clear-old-locations - (let ([old clear-old-locations]) - (λ () - (old) - (off)))))) - - (define in-match-parens? #f) - - ;; the forward matcher signaled an error because not enough of the - ;; tree has been built. - (define/private (f-match-false-error start end error) - (and error (<= (+ start-pos error) current-pos) (not up-to-date?))) - - - ;; If there is no match because the buffer isn't lexed far enough yet, - ;; this will do nothing, but the edit sequence for changing the colors - ;; will trigger a callback that will call this to try and match again. - ;; This edit sequence is used even if the coloring is disabled in - ;; the preferences, although nothing is actually colored during it. - ;; This leads to the nice behavior that we don't have to block to - ;; highlight parens, and the parens will be highlighted as soon as - ;; possible. - (define/private match-parens - (opt-lambda ([just-clear? #f]) - ;;(printf "(match-parens ~a)~n" just-clear?) - (when (and (not in-match-parens?) - ;; Trying to match open parens while the - ;; background thread is going slows it down. - ;; The random number slows down how often it - ;; tries. - (or just-clear? up-to-date? (= 0 (random 5)))) - (set! in-match-parens? #t) - (begin-edit-sequence #f #f) - (clear-old-locations) - (set! clear-old-locations void) - (when (and (preferences:get 'framework:highlight-parens) - (not just-clear?)) - (let* ((here (get-start-position))) - (when (= here (get-end-position)) - (let-values (((start-f end-f error-f) - (send parens match-forward (- here start-pos)))) - (when (and (not (f-match-false-error start-f end-f error-f)) - start-f end-f) - (highlight start-f end-f here error-f))) - (let-values (((start-b end-b error-b) - (send parens match-backward (- here start-pos)))) - (when (and start-b end-b) - (highlight start-b end-b here error-b)))))) - (end-edit-sequence) - (set! in-match-parens? #f)))) - - ;; See docs - (define/public (forward-match position cutoff) - (do-forward-match position cutoff #t)) - - (define/private (do-forward-match position cutoff skip-whitespace?) - (let ((position - (if skip-whitespace? - (skip-whitespace position 'forward #t) - position))) - (let-values (((start end error) - (send parens match-forward (- position start-pos)))) - (cond - ((f-match-false-error start end error) - (colorer-driver) - (do-forward-match position cutoff #f)) - ((and start end (not error)) - (let ((match-pos (+ start-pos end))) - (cond - ((<= match-pos cutoff) match-pos) - (else #f)))) - ((and start end error) #f) - (else - (let-values (((tok-start tok-end) - (begin - (tokenize-to-pos position) - (send tokens search! (- position start-pos)) - (values (send tokens get-root-start-position) - (send tokens get-root-end-position))))) - (cond - ((or (send parens is-close-pos? tok-start) - (= (+ start-pos tok-end) position)) - #f) - (else - (+ start-pos tok-end))))))))) - - - ;; See docs - (define/public (backward-match position cutoff) - (let ((x (internal-backward-match position cutoff))) - (cond - ((eq? x 'open) #f) - (else x)))) - - (define/private (internal-backward-match position cutoff) - (when stopped? - (error 'backward-match "called on a color:text<%> whose colorer is stopped.")) - (let ((position (skip-whitespace position 'backward #t))) - (let-values (((start end error) - (send parens match-backward (- position start-pos)))) - (cond - ((and start end (not error)) - (let ((match-pos (+ start-pos start))) - (cond - ((>= match-pos cutoff) match-pos) - (else #f)))) - ((and start end error) #f) - (else - (let-values (((tok-start tok-end) - (begin - (send tokens search! - (if (> position start-pos) - (- position start-pos 1) - 0)) - (values (send tokens get-root-start-position) - (send tokens get-root-end-position))))) - (cond - ((or (send parens is-open-pos? tok-start) - (= (+ start-pos tok-start) position)) - 'open) - (else - (+ start-pos tok-start))))))))) - - ;; See docs - (define/public (backward-containing-sexp position cutoff) - (when stopped? - (error 'backward-containing-sexp "called on a color:text<%> whose colorer is stopped.")) - (let loop ((cur-pos position)) - (let ((p (internal-backward-match cur-pos cutoff))) - (cond - ((eq? 'open p) cur-pos) - ((not p) #f) - (else (loop p)))))) - - ;; Determines whether a position is a 'comment, 'string, etc. - (define/public (classify-position position) - (when stopped? - (error 'classify-position "called on a color:text<%> whose colorer is stopped.")) - (tokenize-to-pos position) - (send tokens search! (- position start-pos)) - (send tokens get-root-data)) - - (define/private (tokenize-to-pos position) - (when (and (not up-to-date?) (<= current-pos position)) (colorer-driver) - (tokenize-to-pos position))) - - ;; See docs - (define/public (skip-whitespace position direction comments?) - (when stopped? - (error 'skip-whitespace "called on a color:text<%> whose colorer is stopped.")) + (loop))))) + + ;; See docs + (define/public (start-colorer token-sym->style- get-token- pairs-) + (unless force-stop? + (set! stopped? #f) + (reset-tokens) + (set! should-color? (preferences:get 'framework:coloring-active)) + (set! token-sym->style token-sym->style-) + (set! get-token get-token-) + (set! pairs pairs-) + (set! parens (new paren-tree% (matches pairs))) + ;; (set! timer (current-milliseconds)) + (do-insert/delete start-pos 0))) + + ;; See docs + (define/public stop-colorer + (opt-lambda ((clear-colors #t)) + (set! stopped? #t) + (when (and clear-colors (not frozen?)) + (begin-edit-sequence #f #f) + (change-style (get-fixed-style) start-pos end-pos #f) + (end-edit-sequence)) + (match-parens #t) + (reset-tokens) + (set! pairs null) + (set! token-sym->style #f) + (set! get-token #f))) + + (define/public (is-frozen?) frozen?) + (define/public (is-stopped?) stopped?) + + ;; See docs + (define/public (freeze-colorer) + (when (is-locked?) + (error 'freeze-colorer "called on a locked color:text<%>.")) + (unless frozen? + (finish-now) + (set! frozen? #t))) + + ;; See docs + (define/public thaw-colorer + (opt-lambda ((recolor? #t) + (retokenize? #f)) + (when frozen? + (set! frozen? #f) (cond - ((and (eq? direction 'forward) - (>= position (if (eq? 'end end-pos) (last-position) end-pos))) - position) - ((and (eq? direction 'backward) (<= position start-pos)) - position) - (else - (tokenize-to-pos position) - (send tokens search! (- (if (eq? direction 'backward) (sub1 position) position) - start-pos)) + (stopped? + (stop-colorer)) + ((or force-recolor-after-freeze recolor?) + (cond + (retokenize? + (let ((tn token-sym->style) + (gt get-token) + (p pairs)) + (stop-colorer (not should-color?)) + (start-colorer tn gt p))) + (else + (begin-edit-sequence #f #f) + (finish-now) + (send tokens for-each + (λ (start len type) + (when (and should-color? (should-color-type? type)) + (let ((color (send (get-style-list) find-named-style + (token-sym->style type))) + (sp (+ start-pos start)) + (ep (+ start-pos (+ start len)))) + (change-style color sp ep #f))))) + (end-edit-sequence)))))))) + + + (define/private (toggle-color on?) + (cond + ((and frozen? (not (equal? on? should-color?))) + (set! should-color? on?) + (set! force-recolor-after-freeze #t)) + ((and (not should-color?) on?) + (set! should-color? on?) + (reset-tokens) + (do-insert/delete start-pos 0)) + ((and should-color? (not on?)) + (set! should-color? on?) + (begin-edit-sequence #f #f) + (change-style (get-fixed-style) start-pos end-pos #f) + (end-edit-sequence)))) + + ;; see docs + (define/public (force-stop-colorer stop?) + (set! force-stop? stop?) + (when stop? + (stop-colorer))) + + + ;; ----------------------- Match parentheses ---------------------------- + + (define clear-old-locations void) + + (define mismatch-color (make-object color% "PINK")) + (define/private (get-match-color) (preferences:get 'framework:paren-match-color)) + + (define/private (highlight start end caret-pos error?) + (let ([off (highlight-range (+ start-pos start) (+ start-pos end) + (if error? mismatch-color (get-match-color)) + (and (send (icon:get-paren-highlight-bitmap) + ok?) + (icon:get-paren-highlight-bitmap)) + (= caret-pos (+ start-pos start)))]) + (set! clear-old-locations + (let ([old clear-old-locations]) + (λ () + (old) + (off)))))) + + (define in-match-parens? #f) + + ;; the forward matcher signaled an error because not enough of the + ;; tree has been built. + (define/private (f-match-false-error start end error) + (and error (<= (+ start-pos error) current-pos) (not up-to-date?))) + + + ;; If there is no match because the buffer isn't lexed far enough yet, + ;; this will do nothing, but the edit sequence for changing the colors + ;; will trigger a callback that will call this to try and match again. + ;; This edit sequence is used even if the coloring is disabled in + ;; the preferences, although nothing is actually colored during it. + ;; This leads to the nice behavior that we don't have to block to + ;; highlight parens, and the parens will be highlighted as soon as + ;; possible. + (define/private match-parens + (opt-lambda ([just-clear? #f]) + ;;(printf "(match-parens ~a)~n" just-clear?) + (when (and (not in-match-parens?) + ;; Trying to match open parens while the + ;; background thread is going slows it down. + ;; The random number slows down how often it + ;; tries. + (or just-clear? up-to-date? (= 0 (random 5)))) + (set! in-match-parens? #t) + (begin-edit-sequence #f #f) + (clear-old-locations) + (set! clear-old-locations void) + (when (and (preferences:get 'framework:highlight-parens) + (not just-clear?)) + (let* ((here (get-start-position))) + (when (= here (get-end-position)) + (let-values (((start-f end-f error-f) + (send parens match-forward (- here start-pos)))) + (when (and (not (f-match-false-error start-f end-f error-f)) + start-f end-f) + (highlight start-f end-f here error-f))) + (let-values (((start-b end-b error-b) + (send parens match-backward (- here start-pos)))) + (when (and start-b end-b) + (highlight start-b end-b here error-b)))))) + (end-edit-sequence) + (set! in-match-parens? #f)))) + + ;; See docs + (define/public (forward-match position cutoff) + (do-forward-match position cutoff #t)) + + (define/private (do-forward-match position cutoff skip-whitespace?) + (let ((position + (if skip-whitespace? + (skip-whitespace position 'forward #t) + position))) + (let-values (((start end error) + (send parens match-forward (- position start-pos)))) + (cond + ((f-match-false-error start end error) + (colorer-driver) + (do-forward-match position cutoff #f)) + ((and start end (not error)) + (let ((match-pos (+ start-pos end))) (cond - ((or (eq? 'white-space (send tokens get-root-data)) - (and comments? (eq? 'comment (send tokens get-root-data)))) - (skip-whitespace (+ start-pos - (if (eq? direction 'forward) - (send tokens get-root-end-position) - (send tokens get-root-start-position))) - direction - comments?)) - (else position))))) - - (define/private (get-close-paren pos closers) - (cond - ((null? closers) #f) + ((<= match-pos cutoff) match-pos) + (else #f)))) + ((and start end error) #f) (else - (let* ((c (car closers)) - (l (string-length c))) - (insert c pos) - (let ((m (backward-match (+ l pos) start-pos))) - (cond - ((and m - (send parens is-open-pos? (- m start-pos)) - (send parens is-close-pos? (- pos start-pos))) - (delete pos (+ l pos)) - c) - (else - (delete pos (+ l pos)) - (get-close-paren pos (cdr closers))))))))) - - (inherit insert delete flash-on on-default-char) - ;; See docs - (define/public (insert-close-paren pos char flash? fixup?) - (let ((closer - (begin - (begin-edit-sequence #f #f) - (get-close-paren pos (if fixup? (map symbol->string (map cadr pairs)) null))))) - (end-edit-sequence) - (let ((insert-str (if closer closer (string char)))) - (for-each (lambda (c) - (on-default-char (new key-event% (key-code c)))) - (string->list insert-str)) - (when flash? - (unless stopped? - (let ((to-pos (backward-match (+ (string-length insert-str) pos) 0))) - (when (and to-pos - (send parens is-open-pos? (- to-pos start-pos)) - (send parens is-close-pos? (- pos start-pos))) - (flash-on to-pos (+ 1 to-pos))))))))) - - (define/public (debug-printout) - (let* ((x null) - (f (λ (a b c) (set! x (cons (list a b c) x))))) - (send tokens for-each f) - (printf "tokens: ~e~n" (reverse x)) - (set! x null) - (send invalid-tokens for-each f) - (printf "invalid-tokens: ~e~n" (reverse x)) - (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n" - start-pos current-pos invalid-tokens-start) - (printf "parens: ~e~n" (car (send parens test))))) - - ;; ------------------------- Callbacks to Override ---------------------- - - (define/override (lock x) - ;;(printf "(lock ~a)~n" x) - (super lock x) - (when (and restart-callback (not x)) - (set! restart-callback #f) - (queue-callback (λ () (colorer-callback))))) - - - (define/override (on-focus on?) - ;;(printf "(on-focus ~a)~n" on?) - (super on-focus on?) - (match-parens (not on?))) - - (define/augment (after-edit-sequence) - ;;(printf "(after-edit-sequence)~n") + (let-values (((tok-start tok-end) + (begin + (tokenize-to-pos position) + (send tokens search! (- position start-pos)) + (values (send tokens get-root-start-position) + (send tokens get-root-end-position))))) + (cond + ((or (send parens is-close-pos? tok-start) + (= (+ start-pos tok-end) position)) + #f) + (else + (+ start-pos tok-end))))))))) + + + ;; See docs + (define/public (backward-match position cutoff) + (let ((x (internal-backward-match position cutoff))) + (cond + ((eq? x 'open) #f) + (else x)))) + + (define/private (internal-backward-match position cutoff) + (when stopped? + (error 'backward-match "called on a color:text<%> whose colorer is stopped.")) + (let ((position (skip-whitespace position 'backward #t))) + (let-values (((start end error) + (send parens match-backward (- position start-pos)))) + (cond + ((and start end (not error)) + (let ((match-pos (+ start-pos start))) + (cond + ((>= match-pos cutoff) match-pos) + (else #f)))) + ((and start end error) #f) + (else + (let-values (((tok-start tok-end) + (begin + (send tokens search! + (if (> position start-pos) + (- position start-pos 1) + 0)) + (values (send tokens get-root-start-position) + (send tokens get-root-end-position))))) + (cond + ((or (send parens is-open-pos? tok-start) + (= (+ start-pos tok-start) position)) + 'open) + (else + (+ start-pos tok-start))))))))) + + ;; See docs + (define/public (backward-containing-sexp position cutoff) + (when stopped? + (error 'backward-containing-sexp "called on a color:text<%> whose colorer is stopped.")) + (let loop ((cur-pos position)) + (let ((p (internal-backward-match cur-pos cutoff))) + (cond + ((eq? 'open p) cur-pos) + ((not p) #f) + (else (loop p)))))) + + ;; Determines whether a position is a 'comment, 'string, etc. + (define/public (classify-position position) + (when stopped? + (error 'classify-position "called on a color:text<%> whose colorer is stopped.")) + (tokenize-to-pos position) + (send tokens search! (- position start-pos)) + (send tokens get-root-data)) + + (define/private (tokenize-to-pos position) + (when (and (not up-to-date?) (<= current-pos position)) + (colorer-driver) + (tokenize-to-pos position))) + + ;; See docs + (define/public (skip-whitespace position direction comments?) + (when stopped? + (error 'skip-whitespace "called on a color:text<%> whose colorer is stopped.")) + (cond + ((and (eq? direction 'forward) + (>= position (if (eq? 'end end-pos) (last-position) end-pos))) + position) + ((and (eq? direction 'backward) (<= position start-pos)) + position) + (else + (tokenize-to-pos position) + (send tokens search! (- (if (eq? direction 'backward) (sub1 position) position) + start-pos)) + (cond + ((or (eq? 'white-space (send tokens get-root-data)) + (and comments? (eq? 'comment (send tokens get-root-data)))) + (skip-whitespace (+ start-pos + (if (eq? direction 'forward) + (send tokens get-root-end-position) + (send tokens get-root-start-position))) + direction + comments?)) + (else position))))) + + (define/private (get-close-paren pos closers) + (cond + ((null? closers) #f) + (else + (let* ((c (car closers)) + (l (string-length c))) + (insert c pos) + (let ((m (backward-match (+ l pos) start-pos))) + (cond + ((and m + (send parens is-open-pos? (- m start-pos)) + (send parens is-close-pos? (- pos start-pos))) + (delete pos (+ l pos)) + c) + (else + (delete pos (+ l pos)) + (get-close-paren pos (cdr closers))))))))) + + (inherit insert delete flash-on on-default-char) + ;; See docs + (define/public (insert-close-paren pos char flash? fixup?) + (let ((closer + (begin + (begin-edit-sequence #f #f) + (get-close-paren pos (if fixup? (map symbol->string (map cadr pairs)) null))))) + (end-edit-sequence) + (let ((insert-str (if closer closer (string char)))) + (for-each (lambda (c) + (on-default-char (new key-event% (key-code c)))) + (string->list insert-str)) + (when flash? + (unless stopped? + (let ((to-pos (backward-match (+ (string-length insert-str) pos) 0))) + (when (and to-pos + (send parens is-open-pos? (- to-pos start-pos)) + (send parens is-close-pos? (- pos start-pos))) + (flash-on to-pos (+ 1 to-pos))))))))) + + (define/public (debug-printout) + (let* ((x null) + (f (λ (a b c) (set! x (cons (list a b c) x))))) + (send tokens for-each f) + (printf "tokens: ~e~n" (reverse x)) + (set! x null) + (send invalid-tokens for-each f) + (printf "invalid-tokens: ~e~n" (reverse x)) + (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n" + start-pos current-pos invalid-tokens-start) + (printf "parens: ~e~n" (car (send parens test))))) + + ;; ------------------------- Callbacks to Override ---------------------- + + (define/override (lock x) + ;;(printf "(lock ~a)~n" x) + (super lock x) + (when (and restart-callback (not x)) + (set! restart-callback #f) + (queue-callback (λ () (colorer-callback))))) + + + (define/override (on-focus on?) + ;;(printf "(on-focus ~a)~n" on?) + (super on-focus on?) + (match-parens (not on?))) + + (define/augment (after-edit-sequence) + ;;(printf "(after-edit-sequence)~n") + (when (has-focus?) + (match-parens)) + (inner (void) after-edit-sequence)) + + (define/augment (after-set-position) + ;;(printf "(after-set-position)~n") + (unless (local-edit-sequence?) + (when (has-focus?) + (match-parens))) + (inner (void) after-set-position)) + + (define/augment (after-change-style a b) + ;;(printf "(after-change-style)~n") + (unless (get-styles-fixed) + (unless (local-edit-sequence?) (when (has-focus?) - (match-parens)) - (inner (void) after-edit-sequence)) - - (define/augment (after-set-position) - ;;(printf "(after-set-position)~n") - (unless (local-edit-sequence?) - (when (has-focus?) - (match-parens))) - (inner (void) after-set-position)) - - (define/augment (after-change-style a b) - ;;(printf "(after-change-style)~n") - (unless (get-styles-fixed) - (unless (local-edit-sequence?) - (when (has-focus?) - (match-parens)))) - (inner (void) after-change-style a b)) - - (define/augment (on-set-size-constraint) - ;;(printf "(on-set-size-constraint)~n") - (unless (local-edit-sequence?) - (when (has-focus?) - (match-parens))) - (inner (void) on-set-size-constraint)) - - (define/augment (after-insert edit-start-pos change-length) - ;;(printf "(after-insert ~a ~a)~n" edit-start-pos change-length) - (do-insert/delete edit-start-pos change-length) - (inner (void) after-insert edit-start-pos change-length)) - - (define/augment (after-delete edit-start-pos change-length) - ;;(printf "(after-delete ~a ~a)~n" edit-start-pos change-length) - (do-insert/delete edit-start-pos (- change-length)) - (inner (void) after-delete edit-start-pos change-length)) - - (super-new) - - ;; need pref-callback to be in a private field - ;; so that the editor hangs on to the callback - ;; when the editor goes away, so does the callback - (define (pref-callback k v) (toggle-color v)) - (preferences:add-callback 'framework:coloring-active pref-callback #t))) + (match-parens)))) + (inner (void) after-change-style a b)) - (define -text% (text-mixin text:keymap%)) - - (define -text-mode<%> (interface ())) + (define/augment (on-set-size-constraint) + ;;(printf "(on-set-size-constraint)~n") + (unless (local-edit-sequence?) + (when (has-focus?) + (match-parens))) + (inner (void) on-set-size-constraint)) - (define text-mode-mixin - (mixin (mode:surrogate-text<%>) (-text-mode<%>) - ;; The arguments here are only used to be passed to start-colorer. Refer to its - ;; documentation. - (init-field (get-token default-lexer) - (token-sym->style (λ (x) "Standard")) - (matches null)) - - (define/override (on-disable-surrogate text) - (super on-disable-surrogate text) - (send text stop-colorer)) - - (define/override (on-enable-surrogate text) - (super on-enable-surrogate text) - (send text start-colorer token-sym->style get-token matches)) - - (super-new))) + (define/augment (after-insert edit-start-pos change-length) + ;;(printf "(after-insert ~a ~a)~n" edit-start-pos change-length) + (do-insert/delete edit-start-pos change-length) + (inner (void) after-insert edit-start-pos change-length)) + + (define/augment (after-delete edit-start-pos change-length) + ;;(printf "(after-delete ~a ~a)~n" edit-start-pos change-length) + (do-insert/delete edit-start-pos (- change-length)) + (inner (void) after-delete edit-start-pos change-length)) + + (super-new) + + ;; need pref-callback to be in a private field + ;; so that the editor hangs on to the callback + ;; when the editor goes away, so does the callback + (define (pref-callback k v) (toggle-color v)) + (preferences:add-callback 'framework:coloring-active pref-callback #t))) - (define text-mode% (text-mode-mixin mode:surrogate-text%))))) + (define -text% (text-mixin text:keymap%)) + + (define -text-mode<%> (interface ())) + + (define text-mode-mixin + (mixin (mode:surrogate-text<%>) (-text-mode<%>) + ;; The arguments here are only used to be passed to start-colorer. Refer to its + ;; documentation. + (init-field (get-token default-lexer) + (token-sym->style (λ (x) "Standard")) + (matches null)) + + (define/override (on-disable-surrogate text) + (super on-disable-surrogate text) + (send text stop-colorer)) + + (define/override (on-enable-surrogate text) + (super on-enable-surrogate text) + (send text start-colorer token-sym->style get-token matches)) + + (super-new))) + + (define text-mode% (text-mode-mixin mode:surrogate-text%))) diff --git a/collects/framework/private/comment-box.ss b/collects/framework/private/comment-box.ss index 5f0d7dad..87442e72 100644 --- a/collects/framework/private/comment-box.ss +++ b/collects/framework/private/comment-box.ss @@ -1,24 +1,18 @@ -(module comment-box mzscheme +(module comment-box (lib "a-unit.ss") (require (lib "class.ss") (lib "etc.ss") (lib "mred.ss" "mred") - (lib "unitsig.ss") "sig.ss" "../decorated-editor-snip.ss" (lib "include-bitmap.ss" "mrlib") (lib "string-constant.ss" "string-constants")) - (provide comment-box@) - - (define comment-box@ - (unit/sig framework:comment-box^ - (import [text : framework:text^] - [scheme : framework:scheme^] - [keymap : framework:keymap^]) - - (rename [-snip% snip%] - [-text% text%]) + (import [prefix text: framework:text^] + [prefix scheme: framework:scheme^] + [prefix keymap: framework:keymap^]) + (export (rename framework:comment-box^ + (-snip% snip%))) (define snipclass% (class decorated-editor-snipclass% @@ -127,4 +121,4 @@ (make-special-comment "comment")) (super-instantiate ()) (inherit set-snipclass) - (set-snipclass snipclass)))))) \ No newline at end of file + (set-snipclass snipclass)))) \ No newline at end of file diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 281d1966..19315ff5 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -1,7 +1,6 @@ -(module editor mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module editor (lib "a-unit.ss") + (require (lib "class.ss") (lib "string-constant.ss" "string-constants") "sig.ss" "../gui-utils.ss" @@ -9,24 +8,21 @@ (lib "mred-sig.ss" "mred") (lib "file.ss")) - (provide editor@) - - (define editor@ - (unit/sig framework:editor^ - (import mred^ - [autosave : framework:autosave^] - [finder : framework:finder^] - [path-utils : framework:path-utils^] - [keymap : framework:keymap^] - [icon : framework:icon^] - [preferences : framework:preferences^] - [text : framework:text^] - [pasteboard : framework:pasteboard^] - [frame : framework:frame^] - [handler : framework:handler^]) - - (rename [-keymap<%> keymap<%>]) - + (import mred^ + [prefix autosave: framework:autosave^] + [prefix finder: framework:finder^] + [prefix path-utils: framework:path-utils^] + [prefix keymap: framework:keymap^] + [prefix icon: framework:icon^] + [prefix preferences: framework:preferences^] + [prefix text: framework:text^] + [prefix pasteboard: framework:pasteboard^] + [prefix frame: framework:frame^] + [prefix handler: framework:handler^]) + (export (rename framework:editor^ + [-keymap<%> keymap<%>])) + (init-depend mred^ framework:autosave^) + ;; renaming, for editor-mixin where get-file is shadowed by a method. (define mred:get-file get-file) @@ -600,4 +596,4 @@ (set! callback-running? #f)) #f)))) 'framework:update-lock-icon)) - (super-instantiate ())))))) + (super-instantiate ())))) diff --git a/collects/framework/private/exit.ss b/collects/framework/private/exit.ss index cc744471..99b7db4e 100644 --- a/collects/framework/private/exit.ss +++ b/collects/framework/private/exit.ss @@ -1,6 +1,5 @@ -(module exit mzscheme - (require (lib "unitsig.ss") - (lib "string-constant.ss" "string-constants") +(module exit (lib "a-unit.ss") + (require (lib "string-constant.ss" "string-constants") (lib "class.ss") "sig.ss" "../gui-utils.ss" @@ -8,13 +7,10 @@ (lib "file.ss") (lib "etc.ss")) - (provide exit@) - - (define exit@ - (unit/sig framework:exit^ - (import mred^ - [preferences : framework:preferences^]) - (rename (-exit exit)) + (import mred^ + [prefix preferences: framework:preferences^]) + (export (rename framework:exit^ + (-exit exit))) (define can?-callbacks '()) (define on-callbacks '()) @@ -79,4 +75,4 @@ (exit) (set! is-exiting? #f)))] [else - (set! is-exiting? #f)]))))) + (set! is-exiting? #f)]))) diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss index 5db8f716..374dc10b 100644 --- a/collects/framework/private/finder.ss +++ b/collects/framework/private/finder.ss @@ -1,7 +1,6 @@ -(module finder mzscheme +(module finder (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") "sig.ss" "../gui-utils.ss" (lib "class.ss") @@ -11,16 +10,14 @@ (lib "file.ss") (lib "etc.ss")) - (provide finder@) - (define finder@ - (unit/sig framework:finder^ - (import mred^ - [preferences : framework:preferences^] - [keymap : framework:keymap^]) + (import mred^ + [prefix preferences: framework:preferences^] + [prefix keymap: framework:keymap^]) - (rename [-put-file put-file] - [-get-file get-file]) + (export (rename framework:finder^ + [-put-file put-file] + [-get-file get-file])) (define dialog-parent-parameter (make-parameter #f)) @@ -106,4 +103,4 @@ (apply (case (preferences:get 'framework:file-dialogs) [(std) std-get-file] [(common) common-get-file]) - args)))))) + args)))) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 856f2c13..0c7d8caf 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1,7 +1,6 @@ -(module frame mzscheme +(module frame (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") (lib "class.ss") (lib "include.ss") "sig.ss" @@ -12,32 +11,31 @@ (lib "file.ss") (lib "etc.ss")) - (provide frame@) + (import mred^ + [prefix group: framework:group^] + [prefix preferences: framework:preferences^] + [prefix icon: framework:icon^] + [prefix handler: framework:handler^] + [prefix application: framework:application^] + [prefix panel: framework:panel^] + [prefix finder: framework:finder^] + [prefix keymap: framework:keymap^] + [prefix text: framework:text^] + [prefix pasteboard: framework:pasteboard^] + [prefix editor: framework:editor^] + [prefix canvas: framework:canvas^] + [prefix menu: framework:menu^] + [prefix scheme: framework:scheme^] + [prefix exit: framework:exit^] + [prefix comment-box: framework:comment-box^]) - (define frame@ - (unit/sig framework:frame^ - (import mred^ - [group : framework:group^] - [preferences : framework:preferences^] - [icon : framework:icon^] - [handler : framework:handler^] - [application : framework:application^] - [panel : framework:panel^] - [finder : framework:finder^] - [keymap : framework:keymap^] - [text : framework:text^] - [pasteboard : framework:pasteboard^] - [editor : framework:editor^] - [canvas : framework:canvas^] - [menu : framework:menu^] - [scheme : framework:scheme^] - [exit : framework:exit^] - [comment-box : framework:comment-box^]) - - (rename [-editor<%> editor<%>] - [-pasteboard% pasteboard%] - [-text% text%]) + (export (rename framework:frame^ + [-editor<%> editor<%>] + [-pasteboard% pasteboard%] + [-text% text%])) + (init-depend mred^ framework:text^) + (define (reorder-menus frame) (define items (send (send frame get-menu-bar) get-items)) (define (find-menu name) @@ -2374,4 +2372,4 @@ (define searchable% (searchable-text-mixin (searchable-mixin -text%))) (define delegate% (delegate-mixin searchable%)) - (define -pasteboard% (pasteboard-mixin open-here%))))) + (define -pasteboard% (pasteboard-mixin open-here%))) diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index b80a4bb0..ecd96912 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -1,25 +1,21 @@ -(module group mzscheme +(module group (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") (lib "class.ss") "sig.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") (lib "file.ss")) - - (provide group@) - - (define group@ - (unit/sig framework:group^ - (import mred^ - [application : framework:application^] - [frame : framework:frame^] - [preferences : framework:preferences^] - [text : framework:text^] - [canvas : framework:canvas^] - [menu : framework:menu^]) + + (import mred^ + [prefix application: framework:application^] + [prefix frame: framework:frame^] + [prefix preferences: framework:preferences^] + [prefix text: framework:text^] + [prefix canvas: framework:canvas^] + [prefix menu: framework:menu^]) + (export framework:group^) (define-struct frame (frame id)) @@ -322,4 +318,4 @@ (internal-get-the-frame-group))) (define (get-the-frame-group) - (internal-get-the-frame-group))))) + (internal-get-the-frame-group))) diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss index 4722bb45..fd653d25 100644 --- a/collects/framework/private/handler.ss +++ b/collects/framework/private/handler.ss @@ -1,7 +1,6 @@ -(module handler mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module handler (lib "a-unit.ss") + (require (lib "class.ss") (lib "list.ss") (lib "hierlist.ss" "hierlist") "sig.ss" @@ -10,17 +9,16 @@ (lib "file.ss") (lib "string-constant.ss" "string-constants")) - (provide handler@) - - (define handler@ - (unit/sig framework:handler^ - (import mred^ - [finder : framework:finder^] - [group : framework:group^] - [text : framework:text^] - [preferences : framework:preferences^] - [frame : framework:frame^]) - + + (import mred^ + [prefix finder: framework:finder^] + [prefix group: framework:group^] + [prefix text: framework:text^] + [prefix preferences: framework:preferences^] + [prefix frame: framework:frame^]) + (export framework:handler^) + (init-depend framework:frame^) + (define-struct handler (name extension handler)) (define format-handlers '()) @@ -392,4 +390,4 @@ (send *open-directory* set-from-file! file)) (and file - (edit-file file)))))))) + (edit-file file)))))) diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss index e61d24b4..9aef9277 100644 --- a/collects/framework/private/icon.ss +++ b/collects/framework/private/icon.ss @@ -1,17 +1,13 @@ -(module icon mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module icon (lib "a-unit.ss") + (require (lib "class.ss") (lib "include-bitmap.ss" "mrlib") "bday.ss" "sig.ss" (lib "mred-sig.ss" "mred")) + + (import mred^) + (export framework:icon^) - (provide icon@) - - (define icon@ - (unit/sig framework:icon^ - (import mred^) - (define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons")))) (define (get-eof-bitmap) (force eof-bitmap)) @@ -73,4 +69,4 @@ (force (if (mrf-bday?) mrf-off-bitmap - gc-off-bitmap)))))) + gc-off-bitmap)))) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 1ecb5e68..ddb41405 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -1,26 +1,23 @@ -(module keymap mzscheme +(module keymap (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") (lib "class.ss") (lib "list.ss") (lib "mred-sig.ss" "mred") (lib "match.ss") "sig.ss") - (provide keymap@) + + (import mred^ + [prefix preferences: framework:preferences^] + [prefix finder: framework:finder^] + [prefix handler: framework:handler^] + [prefix frame: framework:frame^] + [prefix editor: framework:editor^]) + (export (rename framework:keymap^ + [-get-file get-file])) + (init-depend mred^) - (define keymap@ - (unit/sig framework:keymap^ - (import mred^ - [preferences : framework:preferences^] - [finder : framework:finder^] - [handler : framework:handler^] - [frame : framework:frame^] - [editor : framework:editor^]) - - (rename [-get-file get-file]) - (define user-keybindings-files (make-hash-table 'equal)) (define (add-user-keybindings-file spec) @@ -1342,4 +1339,4 @@ (λ (keymap) (send keymap chain-to-keymap global #t) (ctki keymap))]) - (thunk))))))) + (thunk))))) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index d8b7589c..94e5dc23 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -1,24 +1,22 @@ -(module main mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module main (lib "a-unit.ss") + (require (lib "class.ss") "sig.ss" "../gui-utils.ss" (lib "string-constant.ss" "string-constants") (lib "mred-sig.ss" "mred")) - (provide main@) + (import mred^ + [prefix preferences: framework:preferences^] + [prefix exit: framework:exit^] + [prefix group: framework:group^] + [prefix handler: framework:handler^] + [prefix editor: framework:editor^] + [prefix color-prefs: framework:color-prefs^] + [prefix scheme: framework:scheme^]) + (export framework:main^) + (init-depend framework:preferences^ framework:exit^ framework:editor^ + framework:color-prefs^ framework:scheme^) - (define main@ - (unit/sig framework:main^ - (import mred^ - [preferences : framework:preferences^] - [exit : framework:exit^] - [group : framework:group^] - [handler : framework:handler^] - [editor : framework:editor^] - [color-prefs : framework:color-prefs^] - [scheme : framework:scheme^]) - (application-preferences-handler (λ () (preferences:show-dialog))) (preferences:set-default 'framework:square-bracket:cond/offset @@ -319,4 +317,4 @@ ;; the application. ;(preferences:set 'framework:file-dialogs 'std) - (void)))) + (void)) diff --git a/collects/framework/private/menu.ss b/collects/framework/private/menu.ss index c890e4fb..a406225b 100644 --- a/collects/framework/private/menu.ss +++ b/collects/framework/private/menu.ss @@ -1,15 +1,11 @@ -(module menu mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module menu (lib "a-unit.ss") + (require (lib "class.ss") "sig.ss" (lib "mred-sig.ss" "mred")) - (provide menu@) - - (define menu@ - (unit/sig framework:menu^ - (import mred^ - [preferences : framework:preferences^]) + (import mred^ + [prefix preferences: framework:preferences^]) + (export framework:menu^) (define can-restore<%> (interface (selectable-menu-item<%>) @@ -49,4 +45,4 @@ (define can-restore-menu-item% (can-restore-mixin menu-item%)) (define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)) - (define can-restore-underscore-menu% (can-restore-underscore-mixin menu%))))) + (define can-restore-underscore-menu% (can-restore-underscore-mixin menu%))) diff --git a/collects/framework/private/mode.ss b/collects/framework/private/mode.ss index 90adb906..ec5456dc 100644 --- a/collects/framework/private/mode.ss +++ b/collects/framework/private/mode.ss @@ -1,14 +1,10 @@ -(module mode mzscheme +(module mode (lib "a-unit.ss") (require (lib "surrogate.ss") - (lib "unitsig.ss") (lib "class.ss") "sig.ss") - (provide mode@) - - (define mode@ - (unit/sig framework:mode^ - (import) + (import) + (export framework:mode^) (define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>) (surrogate @@ -51,4 +47,4 @@ (augment #t can-set-size-constraint? ()) (override can-do-edit-operation? (op) (op recursive?)) (augment #t can-load-file? (filename format)) - (augment #t can-save-file? (filename format))))))) + (augment #t can-save-file? (filename format))))) diff --git a/collects/framework/private/number-snip.ss b/collects/framework/private/number-snip.ss index 6b527bc4..c5047be6 100644 --- a/collects/framework/private/number-snip.ss +++ b/collects/framework/private/number-snip.ss @@ -1,18 +1,15 @@ -(module number-snip mzscheme - (require (lib "unitsig.ss") - "sig.ss" +(module number-snip (lib "a-unit.ss") + (require "sig.ss" (lib "mred-sig.ss" "mred") (lib "class.ss") (lib "string-constant.ss" "string-constants")) - (provide number-snip@) - - (define number-snip@ - (unit/sig framework:number-snip^ - (import mred^ - [preferences : framework:preferences^]) - (rename [-snip-class% snip-class%]) + (import mred^ + [prefix preferences: framework:preferences^]) + (export (rename framework:number-snip^ + [-snip-class% snip-class%])) + (init-depend mred^) ;; make-repeating-decimal-snip : number boolean -> snip (define (make-repeating-decimal-snip number e-prefix?) @@ -518,4 +515,4 @@ (define (hash-table-bound? ht key) (let/ec k (hash-table-get ht key (λ () (k #f))) - #t))))) \ No newline at end of file + #t))) \ No newline at end of file diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index 470196ff..189f1231 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -1,18 +1,15 @@ -(module panel mzscheme - (require (lib "unitsig.ss") - (lib "class.ss") +(module panel (lib "a-unit.ss") + (require (lib "class.ss") "sig.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") (lib "etc.ss")) - (provide panel@) - - (define panel@ - (unit/sig framework:panel^ - (import [icon : framework:icon^] - mred^) + (import [prefix icon: framework:icon^] + mred^) + (export framework:panel^) + (init-depend mred^) (define single<%> (interface (area-container<%>) active-child)) (define single-mixin @@ -422,5 +419,5 @@ (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%))) - (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%)))))) + (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%)))) diff --git a/collects/framework/private/pasteboard.ss b/collects/framework/private/pasteboard.ss index e9fdb5d1..73990001 100644 --- a/collects/framework/private/pasteboard.ss +++ b/collects/framework/private/pasteboard.ss @@ -1,20 +1,17 @@ -(module pasteboard mzscheme - (require (lib "unitsig.ss") - "sig.ss" +(module pasteboard (lib "a-unit.ss") + (require "sig.ss" (lib "mred-sig.ss" "mred")) - (provide pasteboard@) - - (define pasteboard@ - (unit/sig framework:pasteboard^ - (import mred^ - [editor : framework:editor^]) - - (rename [-keymap% keymap%]) - + (import mred^ + [prefix editor: framework:editor^]) + (export (rename framework:pasteboard^ + [-keymap% keymap%])) + (init-depend mred^ framework:editor^) + + (define basic% (editor:basic-mixin pasteboard%)) (define standard-style-list% (editor:standard-style-list-mixin basic%)) (define -keymap% (editor:keymap-mixin standard-style-list%)) (define file% (editor:file-mixin -keymap%)) (define backup-autosave% (editor:backup-autosave-mixin file%)) - (define info% (editor:info-mixin backup-autosave%))))) + (define info% (editor:info-mixin backup-autosave%))) diff --git a/collects/framework/private/path-utils.ss b/collects/framework/private/path-utils.ss index f81b52a7..a45302a3 100644 --- a/collects/framework/private/path-utils.ss +++ b/collects/framework/private/path-utils.ss @@ -1,13 +1,9 @@ -(module path-utils mzscheme - (require (lib "unitsig.ss") - "sig.ss" +(module path-utils (lib "a-unit.ss") + (require "sig.ss" (lib "mred-sig.ss" "mred")) - (provide path-utils@) - - (define path-utils@ - (unit/sig framework:path-utils^ - (import) + (import) + (export framework:path-utils^) (define (generate-autosave-name name) (let-values ([(base name dir?) @@ -58,5 +54,5 @@ [(eq? (system-type) 'windows) (build-path base (bytes->path-element (bytes-append name-bytes #".bak")))] [else - (build-path base (bytes->path-element (bytes-append name-bytes #"~")))])))))))) + (build-path base (bytes->path-element (bytes-append name-bytes #"~")))])))))) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 80d06b46..ad6123c2 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -40,9 +40,8 @@ for the last one, need a global "no more initialization can happen" flag. |# -(module preferences mzscheme +(module preferences (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") (lib "class.ss") (lib "file.ss") (lib "etc.ss") @@ -52,16 +51,13 @@ for the last one, need a global "no more initialization can happen" flag. (lib "pretty.ss") (lib "list.ss")) - (provide preferences@) - (define preferences@ - (unit/sig framework:preferences^ - (import mred^ - [exn : framework:exn^] - [exit : framework:exit^] - [panel : framework:panel^] - [frame : framework:frame^]) - - (rename [-read read]) + (import mred^ + [prefix exn: framework:exn^] + [prefix exit: framework:exit^] + [prefix panel: framework:panel^] + [prefix frame: framework:frame^]) + (export framework:preferences^) + (define main-preferences-symbol 'plt:framework-prefs) @@ -922,4 +918,4 @@ for the last one, need a global "no more initialization can happen" flag. (define (add-font-panel) (local-add-font-panel)) - (-read)))) + (-read)) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index be4e2a19..7ae723ee 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1,10 +1,9 @@ ;; originally by Dan Grossman ;; 6/30/95 -(module scheme mzscheme +(module scheme (lib "a-unit.ss") (require "collapsed-snipclass-helpers.ss" (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") (lib "class.ss") "sig.ss" (lib "mred-sig.ss" "mred") @@ -16,31 +15,31 @@ (lib "scheme-lexer.ss" "syntax-color") "../gui-utils.ss") - (provide scheme@) - - (define (scheme-paren:get-paren-pairs) - '(("(" . ")") - ("[" . "]") - ("{" . "}"))) - - (define scheme@ - (unit/sig framework:scheme^ - (import mred^ - [preferences : framework:preferences^] - [icon : framework:icon^] - [keymap : framework:keymap^] - [text : framework:text^] - [editor : framework:editor^] - [frame : framework:frame^] - [comment-box : framework:comment-box^] - [mode : framework:mode^] - [color : framework:color^] - [color-prefs : framework:color-prefs^]) + (import mred^ + [prefix preferences: framework:preferences^] + [prefix icon: framework:icon^] + [prefix keymap: framework:keymap^] + [prefix text: framework:text^] + [prefix editor: framework:editor^] + [prefix frame: framework:frame^] + [prefix comment-box: framework:comment-box^] + [prefix mode: framework:mode^] + [prefix color: framework:color^] + [prefix color-prefs: framework:color-prefs^]) - (rename [-text-mode<%> text-mode<%>] - [-text<%> text<%>] - [-text% text%]) + (export (rename framework:scheme^ + [-text-mode<%> text-mode<%>] + [-text<%> text<%>] + [-text% text%])) + + (init-depend mred^ framework:keymap^ framework:color^ framework:mode^ + framework:text^ framework:editor^) + + (define (scheme-paren:get-paren-pairs) + '(("(" . ")") + ("[" . "]") + ("{" . "}"))) (define text-balanced? (opt-lambda (text [start 0] [in-end #f]) @@ -1651,4 +1650,5 @@ (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) main-panel) - ))) + ) + diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 10298bc3..ac467b20 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -1,107 +1,21 @@ - (module sig mzscheme - (require (lib "unitsig.ss")) + (require (lib "unit.ss")) - (provide framework:menu^ - framework:menu-class^ - framework:menu-fun^ - framework:version^ - framework:version-class^ - framework:version-fun^ - framework:panel^ - framework:panel-class^ - framework:panel-fun^ - framework:exn^ - framework:exn-class^ - framework:exn-fun^ - framework:application^ - framework:application-class^ - framework:application-fun^ - framework:preferences^ - framework:preferences-class^ - framework:preferences-fun^ - framework:autosave^ - framework:autosave-class^ - framework:autosave-fun^ - framework:exit^ - framework:exit-class^ - framework:exit-fun^ - framework:path-utils^ - framework:path-utils-class^ - framework:path-utils-fun^ - framework:finder^ - framework:finder-class^ - framework:finder-fun^ - framework:editor^ - framework:editor-class^ - framework:editor-fun^ - framework:pasteboard^ - framework:pasteboard-class^ - framework:pasteboard-fun^ - framework:text^ - framework:text-class^ - framework:text-fun^ - framework:canvas^ - framework:canvas-class^ - framework:canvas-fun^ - framework:frame^ - framework:frame-class^ - framework:frame-fun^ - framework:group^ - framework:group-class^ - framework:group-fun^ - framework:handler^ - framework:handler-class^ - framework:handler-fun^ - framework:icon^ - framework:icon-class^ - framework:icon-fun^ - framework:keymap^ - framework:keymap-class^ - framework:keymap-fun^ - framework:color^ - framework:color-class^ - framework:color-fun^ - framework:color-prefs^ - framework:color-prefs-class^ - framework:color-prefs-fun^ - framework:scheme^ - framework:scheme-class^ - framework:scheme-fun^ - framework:main^ - framework:main-class^ - framework:main-fun^ - framework:mode^ - framework:mode-class^ - framework:mode-fun^ - framework:color-model^ - framework:color-model-class^ - framework:color-model-fun^ - framework:comment-box-fun^ - framework:comment-box-class^ - framework:comment-box^ - framework:number-snip^ - framework:number-snip-fun^ - framework:number-snip-class^) - - (define-signature framework:number-snip-fun^ + (provide (prefix-all-defined-except framework: framework^) + framework^) + + (define-signature number-snip-class^ + (snip-class%)) + (define-signature number-snip^ extends number-snip-class^ (make-repeating-decimal-snip make-fraction-snip)) - (define-signature framework:number-snip-class^ - (snip-class%)) - (define-signature framework:number-snip^ - ((open framework:number-snip-fun^) - (open framework:number-snip-class^))) - - (define-signature framework:comment-box-fun^ - ()) - (define-signature framework:comment-box-class^ + + (define-signature comment-box-class^ (snipclass snip%)) - (define-signature framework:comment-box^ - ((open framework:comment-box-fun^) - (open framework:comment-box-class^))) - - (define-signature framework:menu-class^ + (define-signature comment-box^ extends comment-box-class^ + ()) + + (define-signature menu-class^ (can-restore<%> can-restore-mixin can-restore-underscore<%> @@ -109,22 +23,16 @@ can-restore-menu-item% can-restore-checkable-menu-item% can-restore-underscore-menu%)) - (define-signature framework:menu-fun^ + (define-signature menu^ extends menu-class^ ()) - (define-signature framework:menu^ - ((open framework:menu-class^) - (open framework:menu-fun^))) - (define-signature framework:version-class^ + (define-signature version-class^ ()) - (define-signature framework:version-fun^ + (define-signature version^ extends version-class^ (add-spec version)) - (define-signature framework:version^ - ((open framework:version-class^) - (open framework:version-fun^))) - (define-signature framework:panel-class^ + (define-signature panel-class^ (single-mixin single<%> @@ -149,32 +57,23 @@ horizontal-dragable<%> horizontal-dragable-mixin horizontal-dragable%)) - (define-signature framework:panel-fun^ + (define-signature panel^ extends panel-class^ ()) - (define-signature framework:panel^ - ((open framework:panel-class^) - (open framework:panel-fun^))) - (define-signature framework:exn-class^ + (define-signature exn-class^ ()) - (define-signature framework:exn-fun^ + (define-signature exn^ extends exn-class^ ((struct exn ()) (struct unknown-preference ()))) - (define-signature framework:exn^ - ((open framework:exn-class^) - (open framework:exn-fun^))) - (define-signature framework:application-class^ + (define-signature application-class^ ()) - (define-signature framework:application-fun^ + (define-signature application^ extends application-class^ (current-app-name)) - (define-signature framework:application^ - ((open framework:application-class^) - (open framework:application-fun^))) - (define-signature framework:preferences-class^ + (define-signature preferences-class^ ()) - (define-signature framework:preferences-fun^ + (define-signature preferences^ extends preferences-class^ (get add-callback set @@ -201,22 +100,16 @@ show-dialog hide-dialog)) - (define-signature framework:preferences^ - ((open framework:preferences-class^) - (open framework:preferences-fun^))) - (define-signature framework:autosave-class^ + (define-signature autosave-class^ (autosavable<%>)) - (define-signature framework:autosave-fun^ + (define-signature autosave^ extends autosave-class^ (register restore-autosave-files/gui)) - (define-signature framework:autosave^ - ((open framework:autosave-class^) - (open framework:autosave-fun^))) - (define-signature framework:exit-class^ + (define-signature exit-class^ ()) - (define-signature framework:exit-fun^ + (define-signature exit^ extends exit-class^ (set-exiting exiting? user-oks-exit @@ -225,22 +118,16 @@ can-exit? on-exit exit)) - (define-signature framework:exit^ - ((open framework:exit-class^) - (open framework:exit-fun^))) - (define-signature framework:path-utils-class^ + (define-signature path-utils-class^ ()) - (define-signature framework:path-utils-fun^ + (define-signature path-utils^ extends path-utils-class^ (generate-autosave-name generate-backup-name)) - (define-signature framework:path-utils^ - ((open framework:path-utils-class^) - (open framework:path-utils-fun^))) - (define-signature framework:finder-class^ + (define-signature finder-class^ ()) - (define-signature framework:finder-fun^ + (define-signature finder^ extends finder-class^ (dialog-parent-parameter default-extension default-filters @@ -251,11 +138,8 @@ common-get-file-list get-file put-file)) - (define-signature framework:finder^ - ((open framework:finder-class^) - (open framework:finder-fun^))) - (define-signature framework:editor-class^ + (define-signature editor-class^ (basic<%> standard-style-list<%> keymap<%> @@ -270,30 +154,24 @@ info-mixin file-mixin backup-autosave-mixin)) - (define-signature framework:editor-fun^ + (define-signature editor^ extends editor-class^ (get-standard-style-list set-standard-style-list-pref-callbacks set-standard-style-list-delta set-default-font-color get-default-color-style-name)) - (define-signature framework:editor^ - ((open framework:editor-class^) - (open framework:editor-fun^))) - (define-signature framework:pasteboard-class^ + (define-signature pasteboard-class^ (basic% standard-style-list% keymap% file% backup-autosave% info%)) - (define-signature framework:pasteboard-fun^ + (define-signature pasteboard^ extends pasteboard-class^ ()) - (define-signature framework:pasteboard^ - ((open framework:pasteboard-class^) - (open framework:pasteboard-fun^))) - (define-signature framework:text-class^ + (define-signature text-class^ (basic<%> foreground-color<%> hide-caret/selection<%> @@ -339,13 +217,10 @@ clever-file-format-mixin ports-mixin input-box-mixin)) - (define-signature framework:text-fun^ + (define-signature text^ extends text-class^ ()) - (define-signature framework:text^ - ((open framework:text-class^) - (open framework:text-fun^))) - (define-signature framework:canvas-class^ + (define-signature canvas-class^ (basic<%> color<%> delegate<%> @@ -363,13 +238,10 @@ delegate-mixin info-mixin wide-snip-mixin)) - (define-signature framework:canvas-fun^ + (define-signature canvas^ extends canvas-class^ ()) - (define-signature framework:canvas^ - ((open framework:canvas-class^) - (open framework:canvas-fun^))) - (define-signature framework:frame-class^ + (define-signature frame-class^ (basic<%> size-pref<%> register-group<%> @@ -415,26 +287,20 @@ info-mixin text-info-mixin pasteboard-info-mixin)) - (define-signature framework:frame-fun^ + (define-signature frame^ extends frame-class^ (reorder-menus remove-empty-menus add-snip-menu-items setup-size-pref)) - (define-signature framework:frame^ - ((open framework:frame-class^) - (open framework:frame-fun^))) - (define-signature framework:group-class^ + (define-signature group-class^ (%)) - (define-signature framework:group-fun^ + (define-signature group^ extends group-class^ (get-the-frame-group)) - (define-signature framework:group^ - ((open framework:group-class^) - (open framework:group-fun^))) - (define-signature framework:handler-class^ + (define-signature handler-class^ ()) - (define-signature framework:handler-fun^ + (define-signature handler^ extends handler-class^ (handler? handler-name handler-extension @@ -450,13 +316,10 @@ set-recent-position set-recent-items-frame-superclass size-recently-opened-files)) - (define-signature framework:handler^ - ((open framework:handler-class^) - (open framework:handler-fun^))) - (define-signature framework:icon-class^ + (define-signature icon-class^ ()) - (define-signature framework:icon-fun^ + (define-signature icon^ extends icon-class^ (get-paren-highlight-bitmap get-autowrap-bitmap get-eof-bitmap @@ -470,15 +333,12 @@ get-gc-on-bitmap get-gc-off-bitmap)) - (define-signature framework:icon^ - ((open framework:icon-class^) - (open framework:icon-fun^))) - (define-signature framework:keymap-class^ + (define-signature keymap-class^ (aug-keymap% aug-keymap<%> aug-keymap-mixin)) - (define-signature framework:keymap-fun^ + (define-signature keymap^ extends keymap-class^ (send-map-function-meta make-meta-prefix-list @@ -504,11 +364,8 @@ add-user-keybindings-file remove-user-keybindings-file)) - (define-signature framework:keymap^ - ((open framework:keymap-class^) - (open framework:keymap-fun^))) - (define-signature framework:color-class^ + (define-signature color-class^ (text<%> text-mixin text% @@ -516,27 +373,20 @@ text-mode<%> text-mode-mixin text-mode%)) - (define-signature framework:color-fun^ + (define-signature color^ extends color-class^ ()) - (define-signature framework:color^ - ((open framework:color-class^) - (open framework:color-fun^))) - (define-signature framework:color-prefs-class^ + (define-signature color-prefs-class^ ()) - (define-signature framework:color-prefs-fun^ + (define-signature color-prefs^ extends color-prefs-class^ (register-color-pref add-to-preferences-panel build-color-selection-panel add-background-preferences-panel marshall-style - unmarshall-style)) - (define-signature framework:color-prefs^ - ((open framework:color-prefs-class^) - (open framework:color-prefs-fun^))) + unmarshall-style)) - - (define-signature framework:scheme-class^ + (define-signature scheme-class^ (text<%> text-mixin text% @@ -549,7 +399,7 @@ sexp-snip% sexp-snip<%>)) - (define-signature framework:scheme-fun^ + (define-signature scheme^ extends scheme-class^ (get-wordbreak-map init-wordbreak-map get-keymap @@ -562,29 +412,20 @@ short-sym->style-name text-balanced?)) - (define-signature framework:scheme^ - ((open framework:scheme-class^) - (open framework:scheme-fun^))) - (define-signature framework:main-class^ ()) - (define-signature framework:main-fun^ ()) - (define-signature framework:main^ - ((open framework:main-class^) - (open framework:main-fun^))) + (define-signature main-class^ ()) + (define-signature main^ extends main-class^ ()) - (define-signature framework:mode-class^ + (define-signature mode-class^ (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)) - (define-signature framework:mode-fun^ ()) - (define-signature framework:mode^ - ((open framework:mode-class^) - (open framework:mode-fun^))) + (define-signature mode^ extends mode-class^ ()) - (define-signature framework:color-model-class^ + (define-signature color-model-class^ ()) - (define-signature framework:color-model-fun^ + (define-signature color-model^ extends color-model-class^ (xyz? xyz-x xyz-y @@ -592,6 +433,33 @@ rgb-color-distance rgb->xyz xyz->rgb)) - (define-signature framework:color-model^ - ((open framework:color-model-class^) - (open framework:color-model-fun^)))) + + (define-signature framework^ + ((open (prefix application: application^)) + (open (prefix version: version^)) + (open (prefix color-model: color-model^)) + (open (prefix exn: exn^)) + (open (prefix mode: mode^)) + (open (prefix exit: exit^)) + (open (prefix menu: menu^)) + (open (prefix preferences: preferences^)) + (open (prefix number-snip: number-snip^)) + (open (prefix autosave: autosave^)) + (open (prefix path-utils: path-utils^)) + (open (prefix icon: icon^)) + (open (prefix keymap: keymap^)) + (open (prefix editor: editor^)) + (open (prefix pasteboard: pasteboard^)) + (open (prefix text: text^)) + (open (prefix color: color^)) + (open (prefix color-prefs: color-prefs^)) + (open (prefix comment-box: comment-box^)) + (open (prefix finder: finder^)) + (open (prefix group: group^)) + (open (prefix canvas: canvas^)) + (open (prefix panel: panel^)) + (open (prefix frame: frame^)) + (open (prefix handler: handler^)) + (open (prefix scheme: scheme^)) + (open (prefix main: main^))))) + diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 66e55dd2..8e679cf6 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -5,9 +5,8 @@ WARNING: printf is rebound in the body of the unit to always |# -(module text mzscheme +(module text (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") (lib "class.ss") (lib "match.ss") "sig.ss" @@ -16,21 +15,19 @@ WARNING: printf is rebound in the body of the unit to always (lib "interactive-value-port.ss" "mrlib") (lib "list.ss") (lib "etc.ss")) - (provide text@) - (define text@ - (unit/sig framework:text^ - (import mred^ - [icon : framework:icon^] - [editor : framework:editor^] - [preferences : framework:preferences^] - [keymap : framework:keymap^] - [color-model : framework:color-model^] - [frame : framework:frame^] - [scheme : framework:scheme^] - [number-snip : framework:number-snip^]) - - (rename [-keymap% keymap%]) + (import mred^ + [prefix icon: framework:icon^] + [prefix editor: framework:editor^] + [prefix preferences: framework:preferences^] + [prefix keymap: framework:keymap^] + [prefix color-model: framework:color-model^] + [prefix frame: framework:frame^] + [prefix scheme: framework:scheme^] + [prefix number-snip: framework:number-snip^]) + (export (rename framework:text^ + [-keymap% keymap%])) + (init-depend framework:editor^) (define original-output-port (current-output-port)) (define (printf . args) @@ -2005,4 +2002,4 @@ WARNING: printf is rebound in the body of the unit to always (define clever-file-format% (clever-file-format-mixin file%)) (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) (define searching% (searching-mixin backup-autosave%)) - (define info% (info-mixin (editor:info-mixin searching%)))))) + (define info% (info-mixin (editor:info-mixin searching%)))) diff --git a/collects/framework/private/version.ss b/collects/framework/private/version.ss index 0e65c977..f82a881b 100644 --- a/collects/framework/private/version.ss +++ b/collects/framework/private/version.ss @@ -1,16 +1,11 @@ -(module version mzscheme - (require (lib "unitsig.ss") - "sig.ss" - (lib "mred-sig.ss" "mred") - (lib "string.ss") - (lib "list.ss")) - - (provide version@) - - (define version@ - (unit/sig framework:version^ - (import) - (rename [-version version]) +(module version (lib "a-unit.ss") + (require "sig.ss" + (lib "mred-sig.ss" "mred") + (lib "string.ss") + (lib "list.ss")) + (import) + (export (rename framework:version^ + [-version version])) (define specs null) @@ -24,4 +19,4 @@ (define (add-spec sep num) (set! specs (cons (list (expr->string sep) (format "~a" num)) - specs)))))) + specs)))) diff --git a/collects/hierlist/hierlist-sig.ss b/collects/hierlist/hierlist-sig.ss index 4542c737..a5201778 100644 --- a/collects/hierlist/hierlist-sig.ss +++ b/collects/hierlist/hierlist-sig.ss @@ -1,16 +1,11 @@ - -(module hierlist-sig mzscheme - (require (lib "unitsig.ss")) - - (provide hierlist^) - (define-signature hierlist^ - (hierarchical-list% - hierarchical-list-item<%> - hierarchical-list-item% - hierarchical-list-compound-item<%> - hierarchical-list-compound-item% - - hierarchical-item-snip% - hierarchical-list-snip%))) +(module hierlist-sig (lib "a-signature.ss") + hierarchical-list% + hierarchical-list-item<%> + hierarchical-list-item% + hierarchical-list-compound-item<%> + hierarchical-list-compound-item% + + hierarchical-item-snip% + hierarchical-list-snip%) diff --git a/collects/hierlist/hierlist-unit.ss b/collects/hierlist/hierlist-unit.ss index 02a7fcb7..ae5c8201 100644 --- a/collects/hierlist/hierlist-unit.ss +++ b/collects/hierlist/hierlist-unit.ss @@ -1,6 +1,6 @@ (module hierlist-unit mzscheme - (require (lib "unitsig.ss") + (require (all-except (lib "unit.ss") rename) (lib "class.ss") (lib "class100.ss") (lib "mred-sig.ss" "mred") @@ -16,10 +16,11 @@ (define turn-down-click (include-bitmap "../icons/turn-down-click.png" 'png)) (provide hierlist@) - (define hierlist@ - (unit/sig hierlist^ - (import mred^) - + (define-unit hierlist@ + (import mred^) + (export hierlist^) + (init-depend mred^) + (define-local-member-name ;; In hierarchical-list% ensure-not-selected) @@ -838,4 +839,4 @@ (allow-tab-exit #t) (send top-buffer set-cursor arrow-cursor) (min-width 150) - (min-height 200))))))) + (min-height 200)))))) diff --git a/collects/hierlist/hierlist.ss b/collects/hierlist/hierlist.ss index d817ad5f..0c802ed5 100644 --- a/collects/hierlist/hierlist.ss +++ b/collects/hierlist/hierlist.ss @@ -1,17 +1,18 @@ (module hierlist mzscheme - (require (lib "unitsig.ss") - (lib "mred-sig.ss" "mred") - (lib "mred.ss" "mred")) - + (require (lib "unit.ss") + (lib "mred-sig.ss" "mred") + (lib "mred-unit.ss" "mred")) + (require "hierlist-sig.ss" - "hierlist-unit.ss") - - - (define-values/invoke-unit/sig hierlist^ - hierlist@ - #f - mred^) + "hierlist-unit.ss") + + (define-compound-unit/infer hl + (import) + (export hierlist^) + (link standard-mred@ hierlist@)) + + (define-values/invoke-unit/infer hl) (provide-signature-elements hierlist^)) diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss index ba8a3420..f26ebe2c 100644 --- a/collects/mred/mred-sig.ss +++ b/collects/mred/mred-sig.ss @@ -1,11 +1,6 @@ -(module mred-sig mzscheme - (require (lib "unitsig.ss")) - - (provide mred^) - (define-signature - mred^ - (add-color<%> +(module mred-sig (lib "a-signature.ss") + add-color<%> add-editor-keymap-functions add-pasteboard-keymap-functions add-text-keymap-functions @@ -206,5 +201,5 @@ write-editor-version write-resource yield - ))) + ) diff --git a/collects/mred/mred-unit.ss b/collects/mred/mred-unit.ss new file mode 100644 index 00000000..b5d8217d --- /dev/null +++ b/collects/mred/mred-unit.ss @@ -0,0 +1,6 @@ +(module mred-unit mzscheme + (require (lib "unit.ss") + "mred-sig.ss" + "mred.ss") + (provide standard-mred@) + (define-unit-from-context standard-mred@ mred^)) \ No newline at end of file