From 3885441eb20e253be57fb7b43d405713734fa704 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 8 Sep 1998 02:54:32 +0000 Subject: [PATCH] ... original commit: 48e4860ed97574ec5b6a36281446b674fad14461 --- collects/framework/main.ss | 141 ++++++++++++++++++++++++++++++---- collects/framework/sig.ss | 41 +++------- notes/mred/MrEd 100 Framework | 24 +++++- 3 files changed, 159 insertions(+), 47 deletions(-) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 86129888..fba07b6f 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -4,24 +4,57 @@ ;; preferences + (preferences:set-default 'framework:highlight-parens #t boolean?) + (preferences:set-default 'framework:fixup-parens #t boolean?) + (preferences:set-default 'framework:paren-match #t boolean?) + (let ([hash-table (make-hash-table)]) + (for-each (lambda (x) (hash-table-put! hash-table x 'define)) + '(define defmacro define-macro + define-values + define-signature define-syntax define-schema)) + (for-each (lambda (x) (hash-table-put! hash-table x 'begin)) + '(cond + begin begin0 delay + unit compound-unit compound-unit/sig + public private + inherit inherit-from + rename rename-from + share share-from + sequence)) + (for-each (lambda (x) (hash-table-put! hash-table x 'lambda)) + '(lambda let let* letrec letrec* recur + let/cc let/ec letcc catch + let-syntax letrec-syntax syntax-case + let-signature fluid-let + let-struct let-macro let-values let*-values + case when unless match + let-enumerate + class class* class-asi class-asi* + define-some do opt-lambda send* + local catch shared + unit/sig + with-handlers with-parameterization + interface + parameterize + call-with-input-file with-input-from-file + with-input-from-port call-with-output-file + with-output-to-file with-output-to-port)) + (mred:preferences:set-preference-un/marshall + 'mred:tabify + (lambda (t) (hash-table-map t list)) + (lambda (l) (let ([h (make-hash-table)]) + (for-each (lambda (x) (apply hash-table-put! h x)) l) + h))) + (mred:preferences:set-preference-default 'mred:tabify hash-table hash-table?)) + + (preferences:set-default 'framework:autosave-delay 300 number?) - (preferences:set-default 'framework:autosaving-on? #t - (lambda (x) - (or (not x) - (eq? x #t)))) - (preferences:set-default 'framework:verify-exit #t - (lambda (x) - (or (not x) - (eq? x #t)))) + (preferences:set-default 'framework:autosaving-on? #t boolean?) + (preferences:set-default 'framework:verify-exit #t boolean?) (preferences:set-default 'framework:delete-forward? (not (eq? (system-type) 'unix)) - (lambda (x) - (or (not x) - (eq? x #t)))) - (preferences:set 'framework:show-periods-in-dirlist #f - (lambda (x) - (or (not x) - (eq? x #t)))) + boolean?) + (preferences:set 'framework:show-periods-in-dirlist #f boolean?) (preferences:set 'framework:file-dialogs (if (eq? wx:platform 'unix) 'common @@ -30,8 +63,84 @@ (or (eq? x 'common) (eq? x 'std)))) - (preferences:read) + (preferences:add-panel + "Indenting" + (lambda (p) + (let*-values + ([(get-keywords) + (lambda (hash-table) + (letrec* ([all-keywords (hash-table-map hash-table list)] + [pick-out (lambda (wanted in out) + (cond + [(null? in) (mzlib:function:quicksort out string<=?)] + [else (if (eq? wanted (cadr (car in))) + (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out)) + (pick-out wanted (cdr in) out))]))]) + (values (pick-out 'begin all-keywords null) + (pick-out 'define all-keywords null) + (pick-out 'lambda all-keywords null))))] + [(begin-keywords define-keywords lambda-keywords) + (get-keywords (mred:preferences:get-preference 'mred:tabify))]) + (let* ([add-callback + (lambda (keyword-type keyword-symbol list-box) + (lambda (button command) + (let ([new-one (mred:gui-utils:get-text-from-user + (string-append "Enter new " keyword-type "-like keyword:") + (string-append keyword-type " Keyword"))]) + (when new-one + (let ([parsed (with-handlers ((exn:read? (lambda (x) #f))) + (read (open-input-string new-one)))]) + (cond + [(and (symbol? parsed) + (hash-table-get (mred:preferences:get-preference 'mred:tabify) + parsed + (lambda () #f))) + (wx:message-box (format "\"~a\" is already a specially indented keyword" parsed) + "Error")] + [(symbol? parsed) + (hash-table-put! (mred:preferences:get-preference 'mred:tabify) + parsed keyword-symbol) + (send list-box append (symbol->string parsed))] + [else (wx:message-box (format "expected a symbol, found: ~a" new-one) "Error")]))))))] + [delete-callback + (lambda (list-box) + (lambda (button command) + (let* ([selections (send list-box get-selections)] + [symbols (map (lambda (x) (string->symbol (send list-box get-string x))) selections)]) + (for-each (lambda (x) (send list-box delete x)) (reverse selections)) + (let ([ht (mred:preferences:get-preference 'mred:tabify)]) + (for-each (lambda (x) (hash-table-remove! ht x)) symbols)))))] + [main-panel (make-object mred:horizontal-panel% p)] + [make-column + (lambda (string symbol keywords) + (let* ([vert (make-object mred:vertical-panel% main-panel)] + [_ (make-object mred:message% vert (string-append string "-like Keywords"))] + [box (make-object mred:list-box% vert null "" wx:const-multiple -1 -1 -1 -1 keywords)] + [button-panel (make-object mred:horizontal-panel% vert)] + [add-button (make-object mred:button% button-panel (add-callback string symbol box) "Add")] + [delete-button (make-object mred:button% button-panel (delete-callback box) "Remove")]) + (send* button-panel + (major-align-center) + (stretchable-in-y #f)) + (send add-button user-min-width (send delete-button get-width)) + box))] + [begin-list-box (make-column "Begin" 'begin begin-keywords)] + [define-list-box (make-column "Define" 'define define-keywords)] + [lambda-list-box (make-column "Lambda" 'lambda lambda-keywords)] + [update-list-boxes + (lambda (hash-table) + (let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)] + [(reset) (lambda (list-box keywords) + (send list-box clear) + (for-each (lambda (x) (send list-box append x)) keywords))]) + (reset begin-list-box begin-keywords) + (reset define-list-box define-keywords) + (reset lambda-list-box lambda-keywords) + #t))]) + (mred:preferences:add-preference-callback 'mred:tabify (lambda (p v) (update-list-boxes v))) + main-panel)))) + (preferences:read) ;; misc other stuff diff --git a/collects/framework/sig.ss b/collects/framework/sig.ss index 13f21437..e09a3d07 100644 --- a/collects/framework/sig.ss +++ b/collects/framework/sig.ss @@ -208,20 +208,9 @@ snip% media-snip%)) -(define-signature mred:canvas^ - (make-wrapping-canvas% - wrapping-canvas% - - make-one-line-canvas% - one-line-canvas% - - make-frame-title-canvas% - frame-title-canvas% - - make-wide-snip-canvas% - wide-snip-canvas% - - number-control%)) +(define-signature framework:canvas^ + (make-wide-snip-canvas% + wide-snip-canvas%)) (define-signature mred:frame^ (frame-width @@ -331,21 +320,15 @@ balanced? backward-containing-sexp)) -(define-signature mred:scheme-mode^ - (scheme-mode-allow-console-eval - scheme-mode-tabify-on-return? - scheme-mode-match-round-to-square? - scheme-media-wordbreak-map - scheme-init-wordbreak-map - setup-global-scheme-mode-keymap - setup-global-scheme-interaction-mode-keymap - global-scheme-mode-keymap - global-scheme-interaction-mode-keymap - make-scheme-mode% - make-scheme-interaction-mode% - scheme-mode% - scheme-interaction-mode% - scheme-mode-style-list)) +(define-signature framework:scheme-mode^ + (wordbreak-map + init-wordbreak-map + style-list + keymap + setup-keymap + make-text% + text<%> + text%)) (define-signature framework:paren^ (balanced? diff --git a/notes/mred/MrEd 100 Framework b/notes/mred/MrEd 100 Framework index 1f4a2329..08324a8f 100644 --- a/notes/mred/MrEd 100 Framework +++ b/notes/mred/MrEd 100 Framework @@ -73,12 +73,24 @@ The eliminated classes are: mred:scheme-interaction-mode% mred:scheme-mode% + :: see the methods of scheme:text% + + mred:scheme-mode-allow-console-eval + mred:scheme-mode-tabify-on-return? + mred:scheme-mode-match-round-to-square? + :: just use drscheme instead of these mred:console-edit% mred:console-frame% mred:editor-frame% mred:transparent-io-edit% + mred:setup-global-scheme-interaction-mode-keymap + mred:global-scheme-interaction-mode-keymap + mred:make-scheme-interaction-mode% + mred:scheme-interaction-mode% + + :: deemed unworthy mred:autoload @@ -146,6 +158,14 @@ The remaining existant classes: Old to new name mapping: + mred:scheme-media-wordbreak-map -> scheme:wordbreak-map + mred:scheme-init-wordbreak-map -> scheme:init-wordbreak-map + mred:setup-global-scheme-mode-keymap -> scheme:setup-keymap + mred:global-scheme-mode-keymap -> scheme:keymap + mred:make-scheme-mode% -> scheme:make-text% ; the meaning is different; see the docs + mred:scheme-mode% -> mred:text% ; the meaning is different; see the docs + mred:scheme-mode-style-list -> scheme:style-list + mred:handler? -> handler:handler? mred:handler-name -> handler:handler-name mred:handler-extension -> handler:handler-extension @@ -244,9 +264,9 @@ NOTE: some used but non-existant interfaces from mred engine: ; text:make-basic% adds ranges, wrapping, move/copy-to-edit text:make-basic% : (interface (editor:basic<%> text<%>)) -> text:basic<%> - text:make-return% : text<%> -> editor:basic<%> + text:make-return% : editor:basic<%> -> editor:basic<%> text:make-searching% : (interface (editor:basic<%> text<%>)) -> text:searching<%> - text:make-clever-file-format% : text<%> -> editor<%> + text:make-clever-file-format% : editor:basic<%> -> editor:basic<%> text:make-scheme% : (interface (editor:basic<%> text<%>)) -> editor:scheme<%> editor-canvas:make-frame-title% : editor-canvas<%> -> editor-canvas<%>