diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor index 024c6ea491..f4d4ac0361 100644 --- a/basis/alias/alias-docs.factor +++ b/basis/alias/alias-docs.factor @@ -6,8 +6,10 @@ HELP: ALIAS: { $values { "new-word" word } { "existing-word" word } } { $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." } { $examples - { $example "ALIAS: sequence-nth nth" - "0 { 10 20 30 } sequence-nth" + { $example "USING: alias prettyprint sequences ;" + "IN: alias.test" + "ALIAS: sequence-nth nth" + "0 { 10 20 30 } sequence-nth ." "10" } } ; diff --git a/basis/alias/authors.txt b/basis/alias/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/alias/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 81e9ab97f7..2c464cc74c 100755 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -1,13 +1,13 @@ IN: alien.structs USING: alien.c-types strings help.markup help.syntax alien.syntax sequences io arrays slots.deprecated -kernel words slots assocs namespaces ; +kernel words slots assocs namespaces accessors ; ! Deprecated code : ($spec-reader-values) ( slot-spec class -- element ) dup ?word-name swap 2array - over slot-spec-name - rot slot-spec-class 2array 2array + over name>> + rot class>> 2array 2array [ { $instance } swap suffix ] assoc-map ; : $spec-reader-values ( slot-spec class -- ) @@ -16,14 +16,14 @@ kernel words slots assocs namespaces ; : $spec-reader-description ( slot-spec class -- ) [ "Outputs the value stored in the " , - { $snippet } rot slot-spec-name suffix , + { $snippet } rot name>> suffix , " slot of " , { $instance } swap suffix , " instance." , ] { } make $description ; : slot-of-reader ( reader specs -- spec/f ) - [ slot-spec-reader eq? ] with find nip ; + [ reader>> eq? ] with find nip ; : $spec-reader ( reader slot-specs class -- ) >r slot-of-reader r> @@ -46,14 +46,14 @@ M: word slot-specs "slots" word-prop ; : $spec-writer-description ( slot-spec class -- ) [ "Stores a new value to the " , - { $snippet } rot slot-spec-name suffix , + { $snippet } rot name>> suffix , " slot of " , { $instance } swap suffix , " instance." , ] { } make $description ; : slot-of-writer ( writer specs -- spec/f ) - [ slot-spec-writer eq? ] with find nip ; + [ writer>> eq? ] with find nip ; : $spec-writer ( writer slot-specs class -- ) >r slot-of-writer r> diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 8671b77c9e..51283e2956 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -11,17 +11,17 @@ IN: alien.structs : struct-offsets ( specs -- size ) 0 [ [ class>> align-offset ] keep - [ set-slot-spec-offset ] 2keep + [ (>>offset) ] 2keep class>> heap-size + ] reduce ; : define-struct-slot-word ( spec word quot -- ) - rot slot-spec-offset prefix define-inline ; + rot offset>> prefix define-inline ; : define-getter ( type spec -- ) [ set-reader-props ] keep [ ] - [ slot-spec-reader ] + [ reader>> ] [ class>> [ c-getter ] [ c-type c-type-boxer-quot ] bi append @@ -31,7 +31,7 @@ IN: alien.structs : define-setter ( type spec -- ) [ set-writer-props ] keep [ ] - [ slot-spec-writer ] + [ writer>> ] [ class>> c-setter ] tri define-struct-slot-word ; diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 36849d4ae3..bfe438fae1 100755 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -244,13 +244,13 @@ ERROR: invalid-timestamp-format ; [ (ymdhms>timestamp) ] with-string-reader ; : (hms>timestamp) ( -- timestamp ) - f f f read-hms instant ; + 0 0 0 read-hms instant ; : hms>timestamp ( str -- timestamp ) [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-ymd f f f instant ; + read-ymd 0 0 0 instant ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 659bd2714e..92dede1655 100755 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -1,7 +1,7 @@ IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel -threads sequences calendar ; +threads sequences calendar accessors ; :: lock-test-0 ( -- ) [let | v [ V{ } clone ] @@ -174,7 +174,7 @@ threads sequences calendar ; ] ; [ lock-timeout-test ] [ - linked-error-thread thread-name "Lock timeout-er" = + linked-error-thread name>> "Lock timeout-er" = ] must-fail-with :: read/write-test ( -- ) diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 810e4430f1..12b5d270d4 100755 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -10,8 +10,8 @@ IN: concurrency.messaging GENERIC: send ( message thread -- ) : mailbox-of ( thread -- mailbox ) - dup thread-mailbox [ ] [ - dup rot set-thread-mailbox + dup mailbox>> [ ] [ + [ >>mailbox drop ] keep ] ?if ; M: thread send ( message thread -- ) diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor index 61ebe744f8..28eea4701e 100755 --- a/basis/float-arrays/float-arrays.factor +++ b/basis/float-arrays/float-arrays.factor @@ -58,8 +58,7 @@ INSTANCE: float-array sequence : 4float-array ( w x y z -- array ) T{ float-array } 4sequence ; inline -: F{ ( parsed -- parsed ) - \ } [ >float-array ] parse-literal ; parsing +: F{ \ } [ >float-array ] parse-literal ; parsing M: float-array pprint-delims drop \ F{ \ } ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 041cff72ba..1ed83956c3 100755 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -41,7 +41,7 @@ ready ; SYMBOL: remote-address -GENERIC: handle-client* ( server -- ) +GENERIC: handle-client* ( threaded-server -- ) > call ; : thread-name ( server-name addrspec -- string ) unparse " connection from " swap 3append ; -: accept-connection ( server -- ) +: accept-connection ( threaded-server -- ) [ accept ] [ addr>> ] bi [ '[ , , , handle-client ] ] [ drop threaded-server get name>> swap thread-name ] 2bi spawn drop ; -: accept-loop ( server -- ) +: accept-loop ( threaded-server -- ) [ threaded-server get semaphore>> [ [ accept-connection ] with-semaphore ] @@ -89,7 +89,7 @@ M: threaded-server handle-client* handler>> call ; if* ] [ accept-loop ] bi ; inline recursive -: started-accept-loop ( server -- ) +: started-accept-loop ( threaded-server -- ) threaded-server get [ sockets>> push ] [ ready>> raise-flag ] bi ; diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index 979ac3dc21..3c77be254c 100755 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -62,7 +62,7 @@ ARTICLE: "network-streams" "Networking" ABOUT: "network-streams" HELP: local -{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $link local-path } " slot holds the path name of the socket. New instances are created by calling " { $link } "." } +{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $snippet "path" } " slot holds the path name of the socket. New instances are created by calling " { $link } "." } { $examples { $code "\"/tmp/.X11-unix/0\" " } } ; diff --git a/basis/persistent/heaps/heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor index dbfadc4ed2..a56022a039 100644 --- a/basis/persistent/heaps/heaps-docs.factor +++ b/basis/persistent/heaps/heaps-docs.factor @@ -38,7 +38,7 @@ HELP: pheap>alist { $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ; HELP: pheap>values -{ $values { "heap" "a persistent heap" } { "values" array } } +{ $values { "heap" "a persistent heap" } { "seq" array } } { $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ; ARTICLE: "persistent-heaps" "Persistent heaps" diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index da308f5abf..3c4715d3e3 100755 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -38,7 +38,7 @@ ARTICLE: "thread-state" "Thread-local state and variables" { $subsection tchange } "Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set." $nl -"Global hashtable of all threads, keyed by " { $link thread-id } ":" +"Global hashtable of all threads, keyed by " { $snippet "id" } ":" { $subsection threads } "Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; @@ -63,10 +63,10 @@ ABOUT: "threads" HELP: thread { $class-description "A thread. The slots are as follows:" { $list - { { $link thread-id } " - a unique identifier assigned to each thread." } - { { $link thread-name } " - the name passed to " { $link spawn } "." } - { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." } - { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } + { { $snippet "id" } " - a unique identifier assigned to each thread." } + { { $snippet "name" } " - the name passed to " { $link spawn } "." } + { { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." } + { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } } } ; diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor index 2c01f04bb3..1b75e46e25 100755 --- a/basis/tools/threads/threads.factor +++ b/basis/tools/threads/threads.factor @@ -6,14 +6,14 @@ heaps.private system math math.parser math.order accessors ; IN: tools.threads : thread. ( thread -- ) - dup thread-id pprint-cell - dup thread-name over [ write-object ] with-cell - dup thread-state [ + dup id>> pprint-cell + dup name>> over [ write-object ] with-cell + dup state>> [ [ dup self eq? "running" "yield" ? ] unless* write ] with-cell [ - thread-sleep-entry [ + sleep-entry>> [ key>> millis [-] number>string write " ms" write ] when* diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 6328a3d06d..08eb3d7c32 100755 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -4,7 +4,7 @@ USING: kernel io io.styles io.files io.encodings.utf8 vocabs.loader vocabs sequences namespaces math.parser arrays hashtables assocs memoize summary sorting splitting combinators source-files debugger continuations compiler.errors init -checksums checksums.crc32 sets ; +checksums checksums.crc32 sets accessors ; IN: tools.vocabs : vocab-tests-file ( vocab -- path ) @@ -61,10 +61,10 @@ SYMBOL: failures : source-modified? ( path -- ? ) dup source-files get at [ - dup source-file-path + dup path>> dup exists? [ utf8 file-lines crc32 checksum-lines - swap source-file-checksum = not + swap checksum>> = not ] [ 2drop f ] if @@ -175,7 +175,7 @@ M: vocab summary [ dup vocab-summary % " (" % - vocab-words assoc-size # + words>> assoc-size # " words)" % ] "" make ; diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor index 1fded308b4..2b252404d6 100755 --- a/basis/tools/walker/debug/debug.factor +++ b/basis/tools/walker/debug/debug.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.promises models tools.walker kernel sequences concurrency.messaging locals continuations -threads namespaces namespaces.private assocs ; +threads namespaces namespaces.private assocs accessors ; IN: tools.walker.debug :: test-walker ( quot -- data ) @@ -26,6 +26,6 @@ IN: tools.walker.debug send-synchronous drop p ?promise - thread-variables walker-continuation swap at - model-value continuation-data + variables>> walker-continuation swap at + model-value data>> ] ; diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index f9055fb6cf..cb5283e797 100755 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -22,8 +22,8 @@ DEFER: start-walker-thread : get-walker-thread ( -- status continuation thread ) walker-thread tget [ - [ thread-variables walker-status swap at ] - [ thread-variables walker-continuation swap at ] + [ variables>> walker-status swap at ] + [ variables>> walker-continuation swap at ] [ ] tri ] [ f @@ -43,7 +43,7 @@ DEFER: start-walker-thread } cond ; : break ( -- ) - continuation callstack over set-continuation-call + continuation callstack >>call show-walker send-synchronous after-break ; @@ -248,7 +248,7 @@ SYMBOL: +stopped+ : associate-thread ( walker -- ) walker-thread tset [ f walker-thread tget send-synchronous drop ] - self set-thread-exit-handler ; + self (>>exit-handler) ; : start-walker-thread ( status continuation -- thread' ) self [ @@ -258,7 +258,7 @@ SYMBOL: +stopped+ V{ } clone walker-history tset walker-loop ] 3curry - "Walker on " self thread-name append spawn + "Walker on " self name>> append spawn [ associate-thread ] keep ; ! For convenience diff --git a/basis/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor index 4ee54cd833..e1b591dfb9 100644 --- a/basis/ui/clipboards/clipboards.factor +++ b/basis/ui/clipboards/clipboards.factor @@ -1,10 +1,22 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ui.gadgets ui.gestures namespaces ; + +USING: kernel accessors ui.gadgets ui.gestures namespaces ; + IN: ui.clipboards ! Two text transfer buffers + TUPLE: clipboard contents ; + +GENERIC: clipboard-contents ( clipboard -- string ) + +GENERIC: set-clipboard-contents ( string clipboard -- ) + +M: clipboard clipboard-contents contents>> ; + +M: clipboard set-clipboard-contents (>>contents) ; + : ( -- clipboard ) "" clipboard boa ; GENERIC: paste-clipboard ( gadget clipboard -- ) @@ -20,11 +32,10 @@ SYMBOL: clipboard SYMBOL: selection : gadget-copy ( gadget clipboard -- ) - over gadget-selection? [ - >r [ gadget-selection ] keep r> copy-clipboard - ] [ - 2drop - ] if ; + over gadget-selection? + [ >r [ gadget-selection ] keep r> copy-clipboard ] + [ 2drop ] + if ; : com-copy ( gadget -- ) clipboard get gadget-copy ; diff --git a/basis/ui/freetype/freetype-docs.factor b/basis/ui/freetype/freetype-docs.factor index 855df9f564..ef01c6756c 100755 --- a/basis/ui/freetype/freetype-docs.factor +++ b/basis/ui/freetype/freetype-docs.factor @@ -16,12 +16,35 @@ HELP: init-freetype { $notes "Do not call this word if you are using the UI." } ; HELP: font -{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:" - { $list - { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." } - { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." } - { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." } - } + +{ $class-description + +"A font which has been loaded by FreeType. Font instances have the following slots:" + +{ + $list + { + { $snippet "ascent" } ", " + { $snippet "descent" } ", " + { $snippet "height" } " - metrics." + } + + { + { $snippet "handle" } + " - alien pointer to an " + { $snippet "FT_Face" } "." + } + + { + { $snippet "widths" } + " - sequence of character widths. Use " + { $snippet "width" } + " and " + { $snippet "width" } + " to compute string widths instead of reading this sequence directly." + } +} + } ; HELP: close-freetype diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 487da931eb..7042811881 100755 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -33,7 +33,7 @@ ascent descent height handle widths ; M: font hashcode* drop font hashcode* ; -: close-font ( font -- ) font-handle FT_Done_Face ; +: close-font ( font -- ) handle>> FT_Done_Face ; : close-freetype ( -- ) global [ @@ -111,11 +111,11 @@ M: freetype-renderer open-font ( font -- open-font ) freetype drop open-fonts get [ ] cache ; : load-glyph ( font char -- glyph ) - >r font-handle dup r> 0 FT_Load_Char + >r handle>> dup r> 0 FT_Load_Char freetype-error face-glyph ; : char-width ( open-font char -- w ) - over font-widths [ + over widths>> [ dupd load-glyph glyph-hori-advance ft-ceil ] cache nip ; @@ -123,7 +123,7 @@ M: freetype-renderer string-width ( open-font string -- w ) 0 -rot [ char-width + ] with each ; M: freetype-renderer string-height ( open-font string -- h ) - drop font-height ; + drop height>> ; : glyph-size ( glyph -- dim ) dup glyph-hori-advance ft-ceil @@ -166,7 +166,7 @@ M: freetype-renderer string-height ( open-font string -- h ) : glyph-texture-loc ( glyph font -- loc ) over glyph-hori-bearing-x ft-floor -rot - font-ascent swap glyph-hori-bearing-y - ft-floor 2array ; + ascent>> swap glyph-hori-bearing-y - ft-floor 2array ; : glyph-texture-size ( glyph -- dim ) [ glyph-bitmap-width next-power-of-2 ] diff --git a/basis/ui/gadgets/books/books-docs.factor b/basis/ui/gadgets/books/books-docs.factor index 01426b4457..f6f5d7dd4d 100755 --- a/basis/ui/gadgets/books/books-docs.factor +++ b/basis/ui/gadgets/books/books-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.gadgets models ; IN: ui.gadgets.books HELP: book -{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." +{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $snippet "visible?" } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." $nl "Books are created by calling " { $link } "." } ; diff --git a/basis/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor index 3ff9c63726..161677b56a 100755 --- a/basis/ui/gadgets/books/books.factor +++ b/basis/ui/gadgets/books/books.factor @@ -5,7 +5,7 @@ IN: ui.gadgets.books TUPLE: book < gadget ; -: hide-all ( book -- ) gadget-children [ hide-gadget ] each ; +: hide-all ( book -- ) children>> [ hide-gadget ] each ; : current-page ( book -- gadget ) [ control-value ] keep nth-gadget ; diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 59270ead79..b975416e97 100755 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -5,7 +5,7 @@ IN: ui.gadgets.buttons HELP: button { $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation." $nl -"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "." +"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-paint } "." $nl "A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link } " word to construct a row of buttons for choosing among several alternatives." } ; diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 3f52ee9511..09bf036c9a 100755 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -119,9 +119,9 @@ M: checkmark-paint draw-interior black black - over set-gadget-interior + over (>>interior) black - swap set-gadget-boundary ; + swap (>>boundary) ; : ( -- gadget ) @@ -165,9 +165,9 @@ M: radio-paint draw-boundary black black - over set-gadget-interior + over (>>interior) black - swap set-gadget-boundary ; + swap (>>boundary) ; : ( -- gadget ) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 301121cdcc..d8810824c6 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -38,12 +38,12 @@ focused? ; : activate-editor-model ( editor model -- ) 2dup add-connection dup activate-model - swap gadget-model add-loc ; + swap model>> add-loc ; : deactivate-editor-model ( editor model -- ) 2dup remove-connection dup deactivate-model - swap gadget-model remove-loc ; + swap model>> remove-loc ; M: editor graft* dup @@ -60,11 +60,11 @@ M: editor ungraft* : editor-mark* ( editor -- loc ) editor-mark model-value ; : set-caret ( loc editor -- ) - [ gadget-model validate-loc ] keep + [ model>> validate-loc ] keep editor-caret set-model ; : change-caret ( editor quot -- ) - over >r >r dup editor-caret* swap gadget-model r> call r> + over >r >r dup editor-caret* swap model>> r> call r> set-caret ; inline : mark>caret ( editor -- ) @@ -81,7 +81,7 @@ M: editor ungraft* editor-font* "" string-height ; : y>line ( y editor -- line# ) - [ line-height / >fixnum ] keep gadget-model validate-line ; + [ line-height / >fixnum ] keep model>> validate-line ; : point>loc ( point editor -- loc ) [ @@ -121,7 +121,7 @@ M: editor ungraft* line-height 0 swap 2array ; : scroll>caret ( editor -- ) - dup gadget-graft-state second [ + dup graft-state>> second [ dup caret-loc over caret-dim { 1 0 } v+ over scroll>rect ] when drop ; @@ -157,7 +157,7 @@ M: editor ungraft* swap dup first-visible-line \ first-visible-line set dup last-visible-line \ last-visible-line set - dup gadget-model document set + dup model>> document set editor set call ] with-scope ; inline @@ -227,19 +227,19 @@ M: editor gadget-selection? selection-start/end = not ; M: editor gadget-selection - [ selection-start/end ] keep gadget-model doc-range ; + [ selection-start/end ] keep model>> doc-range ; : remove-selection ( editor -- ) - [ selection-start/end ] keep gadget-model remove-doc-range ; + [ selection-start/end ] keep model>> remove-doc-range ; M: editor user-input* - [ selection-start/end ] keep gadget-model set-doc-range t ; + [ selection-start/end ] keep model>> set-doc-range t ; : editor-string ( editor -- string ) - gadget-model doc-string ; + model>> doc-string ; : set-editor-string ( string editor -- ) - gadget-model set-doc-string ; + model>> set-doc-string ; M: editor gadget-text* editor-string % ; @@ -257,12 +257,12 @@ M: editor gadget-text* editor-string % ; : drag-selection-caret ( loc editor element -- loc ) >r [ drag-direction? ] 2keep - gadget-model + model>> r> prev/next-elt ? ; : drag-selection-mark ( loc editor element -- loc ) >r [ drag-direction? not ] 2keep - nip dup editor-mark* swap gadget-model + nip dup editor-mark* swap model>> r> prev/next-elt ? ; : drag-caret&mark ( editor -- caret mark ) @@ -282,8 +282,8 @@ M: editor gadget-text* editor-string % ; over gadget-selection? [ drop nip remove-selection ] [ - over >r >r dup editor-caret* swap gadget-model - r> call r> gadget-model remove-doc-range + over >r >r dup editor-caret* swap model>> + r> call r> model>> remove-doc-range ] if ; inline : editor-delete ( editor elt -- ) @@ -309,7 +309,7 @@ M: editor gadget-text* editor-string % ; : select-elt ( editor elt -- ) over >r - >r dup editor-caret* swap gadget-model r> prev/next-elt + >r dup editor-caret* swap model>> r> prev/next-elt r> editor-select ; : start-of-document ( editor -- ) T{ doc-elt } editor-prev ; diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor index f0ba3518bd..394841c599 100755 --- a/basis/ui/gadgets/gadgets-docs.factor +++ b/basis/ui/gadgets/gadgets-docs.factor @@ -31,7 +31,7 @@ HELP: user-input* HELP: children-on { $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } } { $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." } -{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ; +{ $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ; HELP: pick-up { $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } } @@ -57,7 +57,7 @@ HELP: gadget-selection HELP: relayout { $values { "gadget" gadget } } -{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ; +{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $snippet "root?" } " set, so this word should be used when the gadget's dimensions have potentially changed." } ; HELP: relayout-1 { $values { "gadget" gadget } } @@ -170,7 +170,7 @@ HELP: focusable-child { $values { "gadget" gadget } { "child" gadget } } { $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ; -{ control-value set-control-value gadget-model } related-words +{ control-value set-control-value } related-words HELP: control-value { $values { "control" gadget } { "value" object } } @@ -181,10 +181,9 @@ HELP: set-control-value { $description "Sets the value of the control's model." } ; ARTICLE: "ui-control-impl" "Implementing controls" -"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance." +"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $snippet "model" } " slot set to a " { $link model } " instance." $nl "Some utility words useful in control implementations:" -{ $subsection gadget-model } { $subsection control-value } { $subsection set-control-value } { $see-also "models" } ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 9a5f53ac4a..bcf908571c 100755 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -150,7 +150,7 @@ DEFER: relayout : invalidate* ( gadget -- ) \ invalidate* over (>>layout-state) dup forget-pref-dim - dup gadget-root? + dup root?>> [ layout-later ] [ parent>> [ relayout ] when* ] if ; : relayout ( gadget -- ) diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index eb2cdad801..4b60b9e5c8 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -77,13 +77,14 @@ M: grid pref-dim* M: grid layout* dup compute-grid grid-layout ; M: grid children-on ( rect gadget -- seq ) - dup gadget-children empty? [ - 2drop f - ] [ + dup children>> empty? + [ 2drop f ] + [ { 0 1 } swap grid>> [ 0 fast-children-on ] keep concat - ] if ; + ] + if ; M: grid gadget-text* grid>> diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index 8c227d76ce..826be68b97 100755 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/basis/ui/gadgets/incremental/incremental.factor @@ -23,7 +23,7 @@ TUPLE: incremental < pack cursor ; { 0 0 } >>cursor ; M: incremental pref-dim* - dup gadget-layout-state [ + dup layout-state>> [ dup call-next-method over set-incremental-cursor ] when incremental-cursor ; @@ -31,13 +31,13 @@ M: incremental pref-dim* [ swap rect-dim swap incremental-cursor 2dup v+ >r vmax r> - ] keep gadget-orientation set-axis ; + ] keep orientation>> set-axis ; : update-cursor ( gadget incremental -- ) [ next-cursor ] keep set-incremental-cursor ; : incremental-loc ( gadget incremental -- ) - dup incremental-cursor swap gadget-orientation v* + dup incremental-cursor swap orientation>> v* swap set-rect-loc ; : prefer-incremental ( gadget -- ) @@ -51,11 +51,11 @@ M: incremental pref-dim* 2dup incremental-loc tuck update-cursor dup prefer-incremental - gadget-parent [ invalidate* ] when* ; + parent>> [ invalidate* ] when* ; : clear-incremental ( incremental -- ) not-in-layout dup (clear-gadget) dup forget-pref-dim { 0 0 } over set-incremental-cursor - gadget-parent [ relayout ] when* ; + parent>> [ relayout ] when* ; diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 077e125b9f..49ccd5aabe 100755 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -29,11 +29,11 @@ M: labelled-gadget focusable-child* labelled-gadget-content ; gray close-box swap ; : title-theme ( gadget -- ) - { 1 0 } over set-gadget-orientation + { 1 0 } over (>>orientation) T{ gradient f { T{ rgba f 0.65 0.65 1.0 1.0 } T{ rgba f 0.65 0.45 1.0 1.0 } - } } swap set-gadget-interior ; + } } swap (>>interior) ; : ( text -- label )