suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: 824b5b741a60072823036ef363ec8af77cfd5795
This commit is contained in:
Robby Findler 1998-10-30 15:10:45 +00:00
parent 81fb41f957
commit 2bcea31ff4
5 changed files with 52 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/framework/scheme.ss
View File

@ -20,13 +20,11 @@
(define -text<%> (define -text<%>
(interface () (interface ()
highlight-parens?
highlight-parens highlight-parens
get-limit get-limit
balance-quotes balance-quotes
balance-parens balance-parens
tabify-on-return? tabify-on-return?
match-round-to-square?
tabify tabify
tabify-selection tabify-selection
tabify-all tabify-all
@ -45,14 +43,14 @@
find-down-sexp find-down-sexp
down-sexp down-sexp
remove-parens-forward remove-parens-forward
standard-style-delta
select-forward-sexp select-forward-sexp
select-backward-sexp select-backward-sexp
select-up-sexp select-up-sexp
select-down-sexp select-down-sexp
transpose-sexp transpose-sexp
tab-size)) get-tab-size
set-tab-size))
(define init-wordbreak-map (define init-wordbreak-map
(lambda (map) (lambda (map)
@ -61,9 +59,11 @@
#\- #\-
'(line))))) '(line)))))
(define wordbreak-map (make-object editor-wordbreak-map%)) (define wordbreak-map (make-object editor-wordbreak-map%))
(define (get-wordbreak-map) wordbreak-map)
(init-wordbreak-map wordbreak-map) (init-wordbreak-map wordbreak-map)
(define style-list (make-object style-list%)) (define style-list (make-object style-list%))
(define (get-style-list) style-list)
(define standard-style-delta (define standard-style-delta
(let ([delta (make-object style-delta% 'change-normal)]) (let ([delta (make-object style-delta% 'change-normal)])
(send delta set-delta 'change-family 'modern) (send delta set-delta 'change-family 'modern)
@ -115,7 +115,7 @@
(if (= -1 f) (if (= -1 f)
#f #f
(= (send position-line f) line)))) (= (send position-line f) line))))
scheme-paren:comments)))]) (scheme-paren:get-comments))))])
(private (private
[remove-indents-callback [remove-indents-callback
(preferences:add-callback (preferences:add-callback
@ -134,7 +134,6 @@
(rename [super-on-focus on-focus] (rename [super-on-focus on-focus]
[super-on-change-style on-change-style] [super-on-change-style on-change-style]
[super-after-change-style after-change-style] [super-after-change-style after-change-style]
[super-on-edit-sequence on-edit-sequence]
[super-after-edit-sequence after-edit-sequence] [super-after-edit-sequence after-edit-sequence]
[super-on-insert on-insert] [super-on-insert on-insert]
[super-after-insert after-insert] [super-after-insert after-insert]
@ -159,9 +158,6 @@
(unless (get-styles-fixed) (unless (get-styles-fixed)
(highlight-parens)) (highlight-parens))
(super-after-change-style))] (super-after-change-style))]
[on-edit-sequence
(lambda ()
(super-on-edit-sequence))]
[after-edit-sequence [after-edit-sequence
(lambda () (lambda ()
(unless in-highlight-parens? (unless in-highlight-parens?
@ -206,10 +202,8 @@
(lambda () (lambda ()
(highlight-parens))]) (highlight-parens))])
(public
[highlight-parens? (preferences:get 'framework:highlight-parens)])
(private (private
[highlight-parens? (preferences:get 'framework:highlight-parens)]
[remove-paren-callback (preferences:add-callback [remove-paren-callback (preferences:add-callback
'framework:highlight-parens 'framework:highlight-parens
(lambda (p value) (lambda (p value)
@ -219,7 +213,7 @@
(lambda (pos) (lambda (pos)
(let loop ([pos pos]) (let loop ([pos pos])
(let ([paren-pos (apply max (map (lambda (pair) (find-string (car pair) -1 pos -1 #f)) (let ([paren-pos (apply max (map (lambda (pair) (find-string (car pair) -1 pos -1 #f))
scheme-paren:paren-pairs))]) (scheme-paren:get-paren-pairs)))])
(cond (cond
[(= -1 paren-pos) #f] [(= -1 paren-pos) #f]
[else [else
@ -263,7 +257,7 @@
(lambda (f) (lambda (f)
(lambda (char) (lambda (char)
(ormap (lambda (x) (char=? char (string-ref (f x) 0))) (ormap (lambda (x) (char=? char (string-ref (f x) 0)))
scheme-paren:paren-pairs)))] (scheme-paren:get-paren-pairs))))]
[is-left-paren? (is-paren? car)] [is-left-paren? (is-paren? car)]
[is-right-paren? (is-paren? cdr)]) [is-right-paren? (is-paren? cdr)])
(when (and (= here there) (when (and (= here there)
@ -327,7 +321,7 @@
[fixup-parens? (preferences:get 'framework:fixup-parens)] [fixup-parens? (preferences:get 'framework:fixup-parens)]
[find-match [find-match
(lambda (pos) (lambda (pos)
(let loop ([parens scheme-paren:paren-pairs]) (let loop ([parens (scheme-paren:get-paren-pairs)])
(cond (cond
[(null? parens) #f] [(null? parens) #f]
[else (let* ([paren (car parens)] [else (let* ([paren (car parens)]
@ -364,7 +358,6 @@
[else (insert char)]) [else (insert char)])
#t)))] #t)))]
[tabify-on-return? (lambda () #t)] [tabify-on-return? (lambda () #t)]
[match-round-to-square? (lambda () #t)]
[tabify [tabify
(opt-lambda ([pos (get-start-position)]) (opt-lambda ([pos (get-start-position)])
(let* ([last-pos (last-position)] (let* ([last-pos (last-position)]
@ -655,7 +648,7 @@
(if (and exp-pos (> exp-pos 0)) (if (and exp-pos (> exp-pos 0))
(let ([pos (apply max (let ([pos (apply max
(map paren-pos scheme-paren:paren-pairs))]) (map paren-pos (scheme-paren:get-paren-pairs)))])
(if (= pos -1) ;; all finds failed (if (= pos -1) ;; all finds failed
#f #f
(- pos 1))) ;; subtract one to move outside the paren (- pos 1))) ;; subtract one to move outside the paren
@ -706,8 +699,7 @@
(delete (- closer 2) (- closer 1)) (delete (- closer 2) (- closer 1))
(end-edit-sequence)) (end-edit-sequence))
(bell)) (bell))
#t))] #t))])
[standard-style-delta #f])
(private (private
[select-text [select-text
@ -752,8 +744,12 @@
(insert text-1 start-2 end-2) (insert text-1 start-2 end-2)
(insert text-2 start-1 end-1) (insert text-2 start-1 end-1)
(set-position end-2) (set-position end-2)
(end-edit-sequence)))))))))))] (end-edit-sequence)))))))))))])
(private
[tab-size 8]) [tab-size 8])
(public
[get-tab-size (lambda () tab-size)]
[set-tab-size (lambda (s) (set! tab-size s))])
(sequence (sequence
(apply super-init args) (apply super-init args)
@ -895,4 +891,5 @@
(send keymap map-function "c:c;c:b" "remove-parens-forward"))) (send keymap map-function "c:c;c:b" "remove-parens-forward")))
(define keymap (make-object keymap%)) (define keymap (make-object keymap%))
(setup-keymap keymap)) (setup-keymap keymap)
(define (get-keymap) keymap))

25
collects/framework/sig.ss
View File

@ -80,6 +80,7 @@
(define-signature framework:editor^ (define-signature framework:editor^
(basic<%> (basic<%>
info<%> info<%>
file<%>
backup-autosave<%> backup-autosave<%>
basic-mixin basic-mixin
@ -96,19 +97,23 @@
(define-signature framework:text^ (define-signature framework:text^
(basic<%> (basic<%>
searching<%> searching<%>
return<%>
info<%>
clever-file-format<%>
basic-mixin basic-mixin
return-mixin
searching-mixin searching-mixin
return-mixin
info-mixin
clever-file-format-mixin clever-file-format-mixin
basic% basic%
return% return%
searching%
info%
file% file%
clever-file-format% clever-file-format%
backup-autosave%)) backup-autosave%
searching%
info%))
(define-signature framework:pasteboard% (define-signature framework:pasteboard%
(pasteboard:basic% (pasteboard:basic%
@ -210,19 +215,19 @@
(%)) (%))
(define-signature framework:scheme-paren^ (define-signature framework:scheme-paren^
(paren-pairs (get-comments
quote-pairs get-paren-pairs
comments get-quote-pairs
forward-match forward-match
backward-match backward-match
balanced? balanced?
backward-containing-sexp)) backward-containing-sexp))
(define-signature framework:scheme^ (define-signature framework:scheme^
(wordbreak-map (get-wordbreak-map
init-wordbreak-map init-wordbreak-map
style-list get-style-list
keymap get-keymap
setup-keymap setup-keymap
text-mixin text-mixin
text<%> text<%>

18
collects/framework/standard-menus-items.ss
View File

@ -17,14 +17,14 @@
(define items (define items
(list (make-generic 'get-menu% '(lambda () menu%) (list (make-generic 'get-menu% '(lambda () menu%)
'("The result of this method is used as the class for creating:" '("The result of this method is used as the class for creating the result of these methods:"
"@mlink file-menu %" "@mlink get-file-menu %"
", " ", "
"@mlink edit-menu %" "@mlink get-edit-menu %"
", " ", "
"@mlink windows-menu %" "@mlink get-windows-menu %"
", and" ", and"
"@mlink help-menu %" "@mlink get-help-menu %"
". " ". "
"" ""
"@return : (derived-from \\iscmclass{menu})" "@return : (derived-from \\iscmclass{menu})"
@ -50,7 +50,7 @@
(lambda () m)) (lambda () m))
'("Returns the file menu" '("Returns the file menu"
"See also" "See also"
"@mlink get-menu\%" "@mlink get-menu\\%"
"" ""
"@return : (instance (derived-from \\iscmclass{menu}))")) "@return : (instance (derived-from \\iscmclass{menu}))"))
(make-generic 'get-edit-menu (make-generic 'get-edit-menu
@ -59,7 +59,7 @@
'("Returns the edit menu" '("Returns the edit menu"
"See also" "See also"
"@mlink get-menu\%" "@mlink get-menu\\%"
"" ""
"@return : (instance (derived-from \\iscmclass{menu}))")) "@return : (instance (derived-from \\iscmclass{menu}))"))
(make-generic 'get-windows-menu (make-generic 'get-windows-menu
@ -68,7 +68,7 @@
'("Returns the windows menu" '("Returns the windows menu"
"See also" "See also"
"@mlink get-menu\%" "@mlink get-menu\\%"
"" ""
"@return : (instance (derived-from \\iscmclass{menu}))")) "@return : (instance (derived-from \\iscmclass{menu}))"))
(make-generic 'get-help-menu (make-generic 'get-help-menu
@ -77,7 +77,7 @@
'("Returns the help menu" '("Returns the help menu"
"See also" "See also"
"@mlink get-menu\%" "@mlink get-menu\\%"
"" ""
"@return : (instance (derived-from \\iscmclass{menu}))")) "@return : (instance (derived-from \\iscmclass{menu}))"))

1
collects/framework/test.ss
View File

@ -1,4 +1,5 @@
(printf "1~n") (printf "1~n")
(require-library "errortrace.ss" "errortrace")
(read-case-sensitive #t) (read-case-sensitive #t)
(compile-allow-cond-fallthrough #t) (compile-allow-cond-fallthrough #t)
(compile-allow-set!-undefined #t) (compile-allow-set!-undefined #t)

14
collects/framework/text.ss
View File

@ -312,8 +312,6 @@
(keymap:set-keymap-implied-shifts keymap) (keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap (keymap:get-global) #f))))) (send keymap chain-to-keymap (keymap:get-global) #f)))))
(define file<%> (interface (basic<%>)))
(define searching<%> (define searching<%>
(interface () (interface ()
find-string-embedded)) find-string-embedded))
@ -407,8 +405,10 @@
(keymap:set-keymap-implied-shifts keymap) (keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap (keymap:get-search) #f))))) (send keymap chain-to-keymap (keymap:get-search) #f)))))
(define return<%> (interface (text<%>)))
(define return-mixin (define return-mixin
(mixin (text<%>) (text<%>) (return . args) (mixin (text<%>) (return<%>) (return . args)
(rename [super-on-local-char on-local-char]) (rename [super-on-local-char on-local-char])
(override (override
[on-local-char [on-local-char
@ -423,8 +423,10 @@
(sequence (sequence
(apply super-init args)))) (apply super-init args))))
(define info<%> (interface (editor:basic<%> text<%>)))
(define info-mixin (define info-mixin
(mixin (editor:basic<%> text<%>) (editor:basic<%> text<%>) args (mixin (editor:basic<%> text<%>) (info<%>) args
(inherit get-start-position get-end-position get-canvas (inherit get-start-position get-end-position get-canvas
run-after-edit-sequence) run-after-edit-sequence)
(rename [super-after-set-position after-set-position] (rename [super-after-set-position after-set-position]
@ -471,8 +473,10 @@
(enqueue-for-frame 'edit-position-changed (enqueue-for-frame 'edit-position-changed
'framework:edit-position-changed))]))) 'framework:edit-position-changed))])))
(define clever-file-format<%> (interface (text<%>)))
(define clever-file-format-mixin (define clever-file-format-mixin
(mixin (text<%>) (text<%>) args (mixin (text<%>) (clever-file-format<%>) args
(inherit get-file-format set-file-format find-first-snip) (inherit get-file-format set-file-format find-first-snip)
(rename [super-on-save-file on-save-file] (rename [super-on-save-file on-save-file]
[super-after-save-file after-save-file]) [super-after-save-file after-save-file])