initial Scribble search support
svn: r7738
This commit is contained in:
Matthew Flatt
parent
169ee4cbd1
commit
3ca803a6de
|
|
@ -55,6 +55,12 @@
|
|||
(define/public (get-undefined ri)
|
||||
(hash-table-map (resolve-info-undef ri) (lambda (k v) k)))
|
||||
|
||||
(define/public (transfer-info ci src-ci)
|
||||
(let ([in-ht (collect-info-ext-ht ci)])
|
||||
(hash-table-for-each (collect-info-ext-ht src-ci)
|
||||
(lambda (k v)
|
||||
(hash-table-put! in-ht k v)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; global-info collection
|
||||
|
||||
|
|
@ -193,7 +199,8 @@
|
|||
(collect-put! ci
|
||||
`(index-entry ,(generate-tag (index-element-tag i) ci))
|
||||
(list (index-element-plain-seq i)
|
||||
(index-element-entry-seq i))))
|
||||
(index-element-entry-seq i)
|
||||
(index-element-desc i))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; global-info resolution
|
||||
|
|
@ -269,6 +276,11 @@
|
|||
d ri)]
|
||||
[(element? i)
|
||||
(cond
|
||||
[(index-element? i)
|
||||
(let ([e (index-element-desc i)])
|
||||
(when (delayed-index-desc? e)
|
||||
(let ([v ((delayed-index-desc-resolve e) this d ri)])
|
||||
(hash-table-put! (resolve-info-delays ri) e v))))]
|
||||
[(link-element? i)
|
||||
(resolve-get d ri (link-element-tag i))])
|
||||
(for-each (lambda (e)
|
||||
|
|
|
|||
|
|
@ -167,7 +167,8 @@
|
|||
(list (make-target-element #f content `(idx ,tag)))
|
||||
`(idx ,tag)
|
||||
word-seq
|
||||
element-seq))
|
||||
element-seq
|
||||
#f))
|
||||
|
||||
(define (index* word-seq content-seq . s)
|
||||
(let ([key (make-generated-tag)])
|
||||
|
|
|
|||
6
collects/scribble/decode-struct.ss
Normal file
6
collects/scribble/decode-struct.ss
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "struct.ss")
|
||||
|
||||
(provide-structs
|
||||
[part-index-desc ()])
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
(module decode mzscheme
|
||||
(require "struct.ss"
|
||||
"decode-struct.ss"
|
||||
(lib "contract.ss")
|
||||
(lib "class.ss"))
|
||||
|
||||
|
|
@ -75,17 +76,21 @@
|
|||
null
|
||||
tag
|
||||
(part-index-decl-plain-seq k)
|
||||
(part-index-decl-entry-seq k)))
|
||||
(part-index-decl-entry-seq k)
|
||||
#f))
|
||||
keys k-tags)])
|
||||
(append
|
||||
(if title
|
||||
(if (and title (not (or (eq? 'hidden style)
|
||||
(and (list? style)
|
||||
(memq 'hidden style)))))
|
||||
(cons (make-index-element
|
||||
#f
|
||||
null
|
||||
(car tags)
|
||||
(list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title)
|
||||
""))
|
||||
(list (make-element #f title)))
|
||||
(list (make-element #f title))
|
||||
(make-part-index-desc))
|
||||
l)
|
||||
l)
|
||||
colls))
|
||||
|
|
|
|||
18
collects/scribble/manual-struct.ss
Normal file
18
collects/scribble/manual-struct.ss
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "struct.ss"
|
||||
scheme/contract)
|
||||
|
||||
(provide-structs
|
||||
[exported-index-desc ([name symbol?]
|
||||
[from-libs (listof module-path?)])]
|
||||
[(method-index-desc exported-index-desc) ([method-name symbol?])]
|
||||
[(procedure-index-desc exported-index-desc) ()]
|
||||
[(thing-index-desc exported-index-desc) ()]
|
||||
[(struct-index-desc exported-index-desc) ()]
|
||||
[(form-index-desc exported-index-desc) ()]
|
||||
[(class-index-desc exported-index-desc) ()]
|
||||
[(interface-index-desc exported-index-desc) ()])
|
||||
|
||||
|
||||
|
||||
|
|
@ -5,6 +5,7 @@
|
|||
"scheme.ss"
|
||||
"config.ss"
|
||||
"basic.ss"
|
||||
"manual-struct.ss"
|
||||
mzlib/string
|
||||
scheme/class
|
||||
scheme/stxparam
|
||||
|
|
@ -281,7 +282,8 @@
|
|||
(list t)
|
||||
(target-element-tag t)
|
||||
(list (element->string e))
|
||||
(list e))))
|
||||
(list e)
|
||||
'tech)))
|
||||
|
||||
(define (tech #:doc [doc #f] . s)
|
||||
(*tech make-link-element "techlink" doc s))
|
||||
|
|
@ -591,6 +593,15 @@
|
|||
(lambda () e)
|
||||
(lambda () e)))
|
||||
|
||||
(define (get-exporting-libraries render p ri)
|
||||
(resolve-get/tentative p ri '(exporting-libraries #f)))
|
||||
|
||||
(define (with-exporting-libraries proc)
|
||||
(make-delayed-index-desc
|
||||
(lambda (render part ri)
|
||||
(proc
|
||||
(or (get-exporting-libraries render part ri) null)))))
|
||||
|
||||
(define (*defproc mode within-id
|
||||
stx-ids prototypes arg-contractss result-contracts content-thunk)
|
||||
(let ([spacer (hspace 1)]
|
||||
|
|
@ -696,7 +707,13 @@
|
|||
content
|
||||
tag
|
||||
(list (symbol->string mname))
|
||||
content))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-method-index-desc
|
||||
(syntax-e within-id)
|
||||
libs
|
||||
mname)))))
|
||||
tag)
|
||||
(car content)))
|
||||
(*method (car prototype) within-id))))]
|
||||
|
|
@ -714,7 +731,12 @@
|
|||
content
|
||||
tag
|
||||
(list (symbol->string (car prototype)))
|
||||
content))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-procedure-index-desc
|
||||
(car prototype)
|
||||
libs)))))
|
||||
tag)
|
||||
(car content)))
|
||||
(annote-exporting-library
|
||||
|
|
@ -904,7 +926,7 @@
|
|||
stx-id
|
||||
(let* ([name
|
||||
(apply string-append
|
||||
(map symbol->string (car wrappers)))]
|
||||
(map symbol->string (cdar wrappers)))]
|
||||
[tag
|
||||
(register-scheme-definition
|
||||
(datum->syntax stx-id
|
||||
|
|
@ -919,7 +941,13 @@
|
|||
(list content)
|
||||
tag
|
||||
(list name)
|
||||
(list (schemeidfont (make-element "schemevaluelink" (list name))))))
|
||||
(list (schemeidfont (make-element "schemevaluelink" (list name))))
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(let ([name (string->symbol name)])
|
||||
(if (eq? 'info (caar wrappers))
|
||||
(make-struct-index-desc name libs)
|
||||
(make-procedure-index-desc name libs)))))))
|
||||
tag)
|
||||
content))
|
||||
(cdr wrappers))))
|
||||
|
|
@ -952,12 +980,13 @@
|
|||
(let ([name (if (pair? name)
|
||||
(car name)
|
||||
name)])
|
||||
(list* (list name)
|
||||
(list name '?)
|
||||
(list 'make- name)
|
||||
(list* (list 'info name)
|
||||
(list 'type 'struct: name)
|
||||
(list 'predicate name '?)
|
||||
(list 'constructor 'make- name)
|
||||
(append
|
||||
(map (lambda (f)
|
||||
(list name '- (field-name f)))
|
||||
(list 'accessor name '- (field-name f)))
|
||||
fields)
|
||||
(if immutable?
|
||||
null
|
||||
|
|
@ -966,7 +995,7 @@
|
|||
(map (lambda (f)
|
||||
(if (and (pair? (car f))
|
||||
(memq '#:mutable (car f)))
|
||||
(list 'set- name '- (field-name f) '!)
|
||||
(list 'mutator 'set- name '- (field-name f) '!)
|
||||
#f))
|
||||
fields)))))))])
|
||||
(if (pair? name)
|
||||
|
|
@ -1116,7 +1145,10 @@
|
|||
content
|
||||
tag
|
||||
(list (symbol->string name))
|
||||
content))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-thing-index-desc name libs)))))
|
||||
tag)
|
||||
(car content)))
|
||||
spacer ":" spacer
|
||||
|
|
@ -1181,7 +1213,10 @@
|
|||
content
|
||||
tag
|
||||
(list (symbol->string (syntax-e kw-id)))
|
||||
content))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-form-index-desc (syntax-e kw-id) libs)))))
|
||||
content)
|
||||
stag))
|
||||
tag)
|
||||
|
|
@ -1516,7 +1551,7 @@
|
|||
(decode-flow
|
||||
(build-body decl (decl-body decl))))))))))
|
||||
|
||||
(define (*class-doc stx-id super intfs whole-page?)
|
||||
(define (*class-doc stx-id super intfs whole-page? make-index-desc)
|
||||
(let ([spacer (hspace 1)])
|
||||
(make-table
|
||||
'boxed
|
||||
|
|
@ -1532,13 +1567,14 @@
|
|||
make-page-target-element
|
||||
make-toc-target-element)
|
||||
#f
|
||||
(if whole-page?
|
||||
content ; title is already an index entry
|
||||
(list (make-index-element #f
|
||||
content
|
||||
tag
|
||||
(list (symbol->string (syntax-e stx-id)))
|
||||
content)))
|
||||
(list (make-index-element #f
|
||||
content
|
||||
tag
|
||||
(list (symbol->string (syntax-e stx-id)))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-index-desc (syntax-e stx-id) libs)))))
|
||||
tag)
|
||||
(car content)))
|
||||
spacer ":" spacer
|
||||
|
|
@ -1583,7 +1619,8 @@
|
|||
(*class-doc (quote-syntax/loc name)
|
||||
(quote-syntax super)
|
||||
(list (quote-syntax intf) ...)
|
||||
whole-page?)))
|
||||
whole-page?
|
||||
make-class-index-desc)))
|
||||
(list body ...))))]))
|
||||
|
||||
(define-syntax defclass
|
||||
|
|
@ -1609,7 +1646,8 @@
|
|||
(*class-doc (quote-syntax/loc name)
|
||||
#f
|
||||
(list (quote-syntax intf) ...)
|
||||
whole-page?)))
|
||||
whole-page?
|
||||
make-interface-index-desc)))
|
||||
(list body ...))))]))
|
||||
|
||||
(define-syntax definterface
|
||||
|
|
|
|||
|
|
@ -136,7 +136,8 @@
|
|||
[(link-element element) ([tag tag?])]
|
||||
[(index-element element) ([tag tag?]
|
||||
[plain-seq (listof string?)]
|
||||
[entry-seq list?])]
|
||||
[entry-seq list?]
|
||||
[desc any/c])]
|
||||
[(aux-element element) ()]
|
||||
[(hover-element element) ([text string?])]
|
||||
;; specific renders support other elements, especially strings
|
||||
|
|
@ -194,6 +195,38 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Delayed index entry also has special serialization support.
|
||||
;; It uses the same delay -> value table as delayed-element
|
||||
(define-struct delayed-index-desc (resolve)
|
||||
#:mutable
|
||||
#:property
|
||||
prop:serializable
|
||||
(make-serialize-info
|
||||
(lambda (d)
|
||||
(let ([ri (current-serialize-resolve-info)])
|
||||
(unless ri
|
||||
(error 'serialize-delayed-index-desc
|
||||
"current-serialize-resolve-info not set"))
|
||||
(with-handlers ([exn:fail:contract?
|
||||
(lambda (exn)
|
||||
(error 'serialize-index-desc
|
||||
"serialization failed (wrong resolve info?); ~a"
|
||||
(exn-message exn)))])
|
||||
(vector
|
||||
(delayed-element-content d ri)))))
|
||||
#'deserialize-delayed-index-desc
|
||||
#f
|
||||
(or (current-load-relative-directory) (current-directory))))
|
||||
|
||||
(provide/contract
|
||||
(struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)])))
|
||||
|
||||
(provide deserialize-delayed-index-desc)
|
||||
(define deserialize-delayed-index-desc
|
||||
(make-deserialize-info values values))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-struct (collect-element element) (collect)
|
||||
#:mutable
|
||||
#:property
|
||||
|
|
|
|||
95
collects/setup/scribble-index.ss
Normal file
95
collects/setup/scribble-index.ss
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scribble/struct
|
||||
scribble/manual-struct
|
||||
scribble/decode-struct
|
||||
scribble/base-render
|
||||
(prefix-in html: scribble/html-render)
|
||||
scheme/class
|
||||
setup/getinfo
|
||||
setup/dirs
|
||||
syntax/namespace-reflect
|
||||
mzlib/serialize
|
||||
scheme/file)
|
||||
|
||||
(provide load-xref
|
||||
xref-render
|
||||
xref-index
|
||||
(struct-out entry))
|
||||
|
||||
(define-struct entry (words content link-key desc))
|
||||
(define-struct xrefs (renderer ri))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Xref loading
|
||||
|
||||
(define-struct doc (source dest))
|
||||
|
||||
(define-reflection-anchor here)
|
||||
|
||||
(define (load-xref)
|
||||
(let* ([renderer (new (html:render-mixin render%)
|
||||
[dest-dir (find-system-path 'temp-dir)])]
|
||||
[dirs (find-relevant-directories '(scribblings))]
|
||||
[infos (map get-info/full dirs)]
|
||||
[docs (filter
|
||||
values
|
||||
(apply append
|
||||
(map (lambda (i dir)
|
||||
(let ([s (i 'scribblings)])
|
||||
(map (lambda (d)
|
||||
(if (pair? d)
|
||||
(let ([flags (if (pair? (cdr d))
|
||||
(cadr d)
|
||||
null)])
|
||||
(let ([name (if (and (pair? (cdr d))
|
||||
(pair? (cddr d))
|
||||
(caddr d))
|
||||
(cadr d)
|
||||
(let-values ([(base name dir?) (split-path (car d))])
|
||||
(path-replace-suffix name #"")))])
|
||||
(make-doc
|
||||
(build-path dir (car d))
|
||||
(if (memq 'main-doc flags)
|
||||
(build-path (find-doc-dir) name)
|
||||
(build-path dir "compiled" "doc" name)))))
|
||||
#f))
|
||||
s)))
|
||||
infos
|
||||
dirs)))]
|
||||
[ci (send renderer collect null null)])
|
||||
(map (lambda (doc)
|
||||
(parameterize ([current-namespace (reflection-anchor->namespace here)])
|
||||
(with-handlers ([exn:fail? (lambda (exn) exn)])
|
||||
(let ([r (with-input-from-file (build-path (doc-dest doc) "xref-out.ss")
|
||||
read)])
|
||||
(send renderer deserialize-info (cadr r) ci)))))
|
||||
docs)
|
||||
(make-xrefs renderer (send renderer resolve null null ci))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Xref reading
|
||||
|
||||
(define (xref-index xrefs)
|
||||
(filter
|
||||
values
|
||||
(hash-table-map (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
|
||||
(lambda (k v)
|
||||
(and (pair? k)
|
||||
(eq? (car k) 'index-entry)
|
||||
(make-entry (car v)
|
||||
(cadr v)
|
||||
(cadr k)
|
||||
(caddr v)))))))
|
||||
|
||||
(define (xref-render xrefs doc dest-file)
|
||||
(let* ([dest-file (if (string? dest-file)
|
||||
(string->path dest-file)
|
||||
dest-file)]
|
||||
[renderer (new (html:render-mixin render%)
|
||||
[dest-dir (path-only dest-file)])]
|
||||
[ci (send renderer collect (list doc) (list dest-file))])
|
||||
(send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))
|
||||
(let ([ri (send renderer resolve (list doc) (list dest-file) ci)])
|
||||
(send renderer render (list doc) (list dest-file) ri)
|
||||
(void))))
|
||||
|
|
@ -1,4 +1,6 @@
|
|||
|
||||
#lang scheme/gui
|
||||
|
||||
(require (lib "class.ss")
|
||||
(lib "class100.ss")
|
||||
(lib "etc.ss"))
|
||||
|
|
@ -184,7 +186,7 @@
|
|||
(define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX")
|
||||
|
||||
(define-values (icons-path local-path)
|
||||
(let ([d (current-load-relative-directory)])
|
||||
(let ([d (this-expression-source-directory)])
|
||||
(values
|
||||
(lambda (n)
|
||||
(build-path (collection-path "icons") n))
|
||||
|
|
@ -223,7 +225,7 @@
|
|||
(send dc draw-text "Tab in" 0 60))))]
|
||||
[on-event
|
||||
(lambda (e)
|
||||
(if (send e button-down?)
|
||||
(when (send e button-down?)
|
||||
(let ([x (send e get-x)]
|
||||
[y (send e get-y)]
|
||||
[m (if (or (null? last-m)
|
||||
|
|
@ -289,7 +291,7 @@
|
|||
|
||||
(define prev-frame #f)
|
||||
|
||||
(define bitmap%
|
||||
(define bitmap2%
|
||||
(class100 bitmap% args
|
||||
(inherit ok?)
|
||||
(sequence
|
||||
|
|
@ -298,29 +300,27 @@
|
|||
(printf "bitmap failure: ~s~n" args)))))
|
||||
|
||||
(define (active-mixin %)
|
||||
(class100-asi %
|
||||
(private-field
|
||||
[pre-on void]
|
||||
[click-i void]
|
||||
[el void])
|
||||
(rename [super-on-subwindow-event on-subwindow-event]
|
||||
[super-on-subwindow-char on-subwindow-char])
|
||||
(override [on-subwindow-event (lambda args
|
||||
(apply el args)
|
||||
(or (apply pre-on args)
|
||||
(apply click-i args)
|
||||
(super-on-subwindow-event . args)))]
|
||||
[on-subwindow-char (lambda args
|
||||
(or (apply pre-on args)
|
||||
(super-on-subwindow-char . args)))]
|
||||
[on-activate (lambda (on?) (printf "active: ~a~n" on?))]
|
||||
[on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))]
|
||||
[on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
|
||||
(public [set-info
|
||||
(lambda (ep)
|
||||
(set! pre-on (add-pre-note this ep))
|
||||
(set! click-i (add-click-intercept this ep))
|
||||
(set! el (add-enter/leave-note this ep)))])))
|
||||
(class %
|
||||
(define pre-on void)
|
||||
(define click-i void)
|
||||
(define el void)
|
||||
(override* [on-subwindow-event (lambda args
|
||||
(apply el args)
|
||||
(or (apply pre-on args)
|
||||
(apply click-i args)
|
||||
(super on-subwindow-event . args)))]
|
||||
[on-subwindow-char (lambda args
|
||||
(or (apply pre-on args)
|
||||
(super on-subwindow-char . args)))]
|
||||
[on-activate (lambda (on?) (printf "active: ~a~n" on?))]
|
||||
[on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))]
|
||||
[on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
|
||||
(public* [set-info
|
||||
(lambda (ep)
|
||||
(set! pre-on (add-pre-note this ep))
|
||||
(set! click-i (add-click-intercept this ep))
|
||||
(set! el (add-enter/leave-note this ep)))])
|
||||
(super-new)))
|
||||
|
||||
(define active-frame% (active-mixin frame%))
|
||||
(define active-dialog% (active-mixin dialog%))
|
||||
|
|
@ -339,13 +339,13 @@
|
|||
(apply super-init name args))))
|
||||
|
||||
(define return-bmp
|
||||
(make-object bitmap% (icons-path "return.xbm") 'xbm))
|
||||
(make-object bitmap2% (icons-path "return.xbm") 'xbm))
|
||||
(define bb-bmp
|
||||
(make-object bitmap% (icons-path "bb.gif") 'gif))
|
||||
(make-object bitmap2% (icons-path "bb.gif") 'gif))
|
||||
(define mred-bmp
|
||||
(make-object bitmap% (icons-path "mred.xbm") 'xbm))
|
||||
(make-object bitmap2% (icons-path "mred.xbm") 'xbm))
|
||||
(define nruter-bmp
|
||||
(make-object bitmap% (local-path "nruter.xbm") 'xbm))
|
||||
(make-object bitmap2% (local-path "nruter.xbm") 'xbm))
|
||||
|
||||
(define (add-label-direction label-h? l)
|
||||
(if (not label-h?)
|
||||
|
|
@ -1398,18 +1398,15 @@
|
|||
(set! actual-content null)
|
||||
(set! actual-user-data null)
|
||||
(send c clear))))
|
||||
(define (gone l n)
|
||||
(if (zero? n)
|
||||
(cdr l)
|
||||
(cons (car l) (gone (cdr l) (sub1 n)))))
|
||||
(define (delete p)
|
||||
(send c delete p)
|
||||
(when (<= 0 p (sub1 (length actual-content)))
|
||||
(if (zero? p)
|
||||
(begin
|
||||
(set! actual-content (cdr actual-content))
|
||||
(set! actual-user-data (cdr actual-user-data)))
|
||||
(begin
|
||||
(set-cdr! (list-tail actual-content (sub1 p))
|
||||
(list-tail actual-content (add1 p)))
|
||||
(set-cdr! (list-tail actual-user-data (sub1 p))
|
||||
(list-tail actual-user-data (add1 p)))))))
|
||||
(set! actual-content (gone actual-content p))
|
||||
(set! actual-user-data (gone actual-user-data p))))
|
||||
(define db (if list?
|
||||
(make-object button%
|
||||
"Delete" cdp
|
||||
|
|
@ -1646,22 +1643,20 @@
|
|||
(define (canvas-frame flags)
|
||||
(define f (make-frame frame% "Canvas Test" #f #f 250))
|
||||
(define p (make-object vertical-panel% f))
|
||||
(define c% (class100 canvas% (-name -swapped-name p)
|
||||
(define c% (class canvas%
|
||||
(init -name -swapped-name p)
|
||||
(inherit get-dc get-scroll-pos get-scroll-range get-scroll-page
|
||||
get-client-size get-virtual-size get-view-start)
|
||||
(rename [super-init-manual-scrollbars init-manual-scrollbars]
|
||||
[super-init-auto-scrollbars init-auto-scrollbars])
|
||||
(private-field
|
||||
[name -name]
|
||||
[swapped-name -swapped-name]
|
||||
[auto? #f]
|
||||
[incremental? #f]
|
||||
[vw 10]
|
||||
[vh 10])
|
||||
(public
|
||||
(define name -name)
|
||||
(define swapped-name -swapped-name)
|
||||
(define auto? #f)
|
||||
(define incremental? #f)
|
||||
(define vw 10)
|
||||
(define vh 10)
|
||||
(public*
|
||||
[inc-mode (lambda (x) (set! incremental? x))]
|
||||
[set-vsize (lambda (w h) (set! vw w) (set! vh h))])
|
||||
(override
|
||||
(override*
|
||||
[on-paint
|
||||
(lambda ()
|
||||
(let ([s (format "V: p: ~s r: ~s g: ~s H: ~s ~s ~s"
|
||||
|
|
@ -1697,12 +1692,11 @@
|
|||
(unless incremental? (on-paint)))]
|
||||
[init-auto-scrollbars (lambda x
|
||||
(set! auto? #t)
|
||||
(super-init-auto-scrollbars . x))]
|
||||
(super init-auto-scrollbars . x))]
|
||||
[init-manual-scrollbars (lambda x
|
||||
(set! auto? #f)
|
||||
(super-init-manual-scrollbars . x))])
|
||||
(sequence
|
||||
(super-init p flags))))
|
||||
(super init-manual-scrollbars . x))])
|
||||
(super-init p flags)))
|
||||
(define un-name "Unmanaged scroll")
|
||||
(define m-name "Automanaged scroll")
|
||||
(define c1 (make-object c% un-name m-name p))
|
||||
|
|
@ -2118,15 +2112,15 @@
|
|||
(super-init)
|
||||
(start 1000 #t))))))
|
||||
|
||||
(define bp (make-object vertical-panel% ap '(border)))
|
||||
(define bp1 (make-object horizontal-panel% bp))
|
||||
(define bp2 (make-object horizontal-pane% bp))
|
||||
(define bp0 (make-object vertical-panel% ap '(border)))
|
||||
(define bp1 (make-object horizontal-panel% bp0))
|
||||
(define bp2 (make-object horizontal-pane% bp0))
|
||||
(define mp (make-object vertical-panel% ap '(border)))
|
||||
(define mp1 (make-object horizontal-panel% mp))
|
||||
(define mp2 (make-object horizontal-pane% mp))
|
||||
|
||||
(define pp (make-object horizontal-pane% ap))
|
||||
(send bp stretchable-height #f)
|
||||
(send bp0 stretchable-height #f)
|
||||
(make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame)))
|
||||
(make-object horizontal-pane% pp)
|
||||
(make-object button% "Make Panel Frame" pp (lambda (b e) (panel-frame)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user