merged units branch
svn: r5033 original commit: 3459c3a58f1cdc52fbc916acf306b29408468912
This commit is contained in:
Eli Barzilay
parent
2508db4d99
commit
1703ee1e0d
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
(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))))
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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%)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
)))
|
||||
)
|
||||
|
|
@ -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))))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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))))))
|
||||
(set-snipclass snipclass))))
|
||||
|
|
@ -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 ()))))
|
||||
|
|
|
|||
|
|
@ -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)])))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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%)))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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%)))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
#t)))
|
||||
|
|
@ -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%))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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%)))
|
||||
|
|
|
|||
|
|
@ -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 #"~")))]))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
)))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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^)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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%))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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%)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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^))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)))
|
||||
)
|
||||
|
||||
|
|
|
|||
6
collects/mred/mred-unit.ss
Normal file
6
collects/mred/mred-unit.ss
Normal file
|
|
@ -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^))
|
||||
Loading…
Reference in New Issue
Block a user