Permalink
Browse files

assocs: Add of and ?of. Change all the things at once! Fixes #701.

  • Loading branch information...
1 parent b96cb01 commit 38f11415c8cedf4df9adeb113e7a3dcd1a07af5b @erg erg committed Mar 23, 2013
Showing with 145 additions and 135 deletions.
  1. +7 −7 basis/classes/struct/struct-tests.factor
  2. +1 −1 basis/compiler/tree/propagation/branches/branches.factor
  3. +13 −13 basis/furnace/auth/providers/couchdb/couchdb.factor
  4. +1 −1 basis/hashtables/identity/identity-tests.factor
  5. +1 −1 basis/hashtables/sequences/sequences-tests.factor
  6. +5 −5 basis/html/streams/streams.factor
  7. +1 −1 basis/http/http.factor
  8. +3 −3 basis/io/launcher/windows/windows-tests.factor
  9. +1 −1 basis/linked-assocs/linked-assocs-tests.factor
  10. +1 −1 basis/math/statistics/statistics-tests.factor
  11. +1 −1 basis/mime/multipart/multipart-tests.factor
  12. +1 −1 basis/mime/multipart/multipart.factor
  13. +2 −2 basis/peg/ebnf/ebnf.factor
  14. +1 −1 basis/stack-checker/branches/branches.factor
  15. +1 −1 basis/tools/walker/debug/debug.factor
  16. +2 −2 basis/tools/walker/walker.factor
  17. +5 −5 basis/ui/gadgets/panes/panes.factor
  18. +1 −1 basis/unicode/collation/collation.factor
  19. +1 −1 basis/unicode/data/data.factor
  20. +3 −3 basis/xml/elements/elements.factor
  21. +1 −1 basis/xml/syntax/syntax.factor
  22. +1 −1 basis/xmode/marker/marker.factor
  23. +9 −1 core/assocs/assocs-docs.factor
  24. +6 −0 core/assocs/assocs.factor
  25. +1 −1 core/classes/classes.factor
  26. +1 −1 core/hashtables/hashtables-tests.factor
  27. +3 −3 extra/asn1/asn1.factor
  28. +1 −3 extra/assocs/extras/extras.factor
  29. +1 −3 extra/bit/ly/ly.factor
  30. +1 −1 extra/bitcoin/client/client.factor
  31. +1 −1 extra/bson/constants/constants.factor
  32. +5 −5 extra/couchdb/couchdb-tests.factor
  33. +8 −8 extra/couchdb/couchdb.factor
  34. +1 −1 extra/fuel/xref/xref.factor
  35. +2 −2 extra/google/translate/translate.factor
  36. +1 −1 extra/hacker-news/hacker-news.factor
  37. +3 −3 extra/io/streams/256color/256color.factor
  38. +1 −1 extra/irc/client/internals/internals-tests.factor
  39. +3 −3 extra/mongodb/connection/connection.factor
  40. +1 −1 extra/mongodb/driver/driver.factor
  41. +1 −1 extra/oauth/oauth-tests.factor
  42. +7 −7 extra/pdf/canvas/canvas.factor
  43. +3 −3 extra/quadtrees/quadtrees-tests.factor
  44. +5 −5 extra/reddit/reddit.factor
  45. +12 −12 extra/trees/avl/avl-tests.factor
  46. +2 −2 extra/trees/splay/splay-tests.factor
  47. +11 −11 extra/trees/trees-tests.factor
  48. +1 −1 extra/twitter/twitter.factor
@@ -65,13 +65,13 @@ STRUCT: struct-test-bar
make-mirror >alist
] unit-test
-[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
-[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test
-[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test
-[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test
-[ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
-[ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
-[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
+[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } ?of ] unit-test
+[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } ?of ] unit-test
+[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } ?of ] unit-test
+[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } ?of ] unit-test
+[ { "nonexist" "bool" } f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } ?of ] unit-test
+[ "nonexist" f ] [ S{ struct-test-foo } make-mirror "nonexist" ?of ] unit-test
+[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" ?of ] unit-test
[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
@@ -95,7 +95,7 @@ M: #phi propagate-before ( #phi -- )
new [| key value | key old [ value union ] change-at ] assoc-each ;
: include-child-constraints ( i -- )
- infer-children-data get nth constraints swap at last
+ infer-children-data get nth constraints of last
constraints get last update-constraints ;
: branch-phi-constraints ( output values booleans -- )
@@ -45,9 +45,9 @@ TUPLE: couchdb-auth-provider
make-mirror H{ } assoc-like ;
: is-couchdb-conflict-error? ( error -- ? )
- { [ couchdb-error? ] [ data>> "error" swap at "conflict" = ] } 1&& ;
+ { [ couchdb-error? ] [ data>> "error" of "conflict" = ] } 1&& ;
: is-couchdb-not-found-error? ( error -- ? )
- { [ couchdb-error? ] [ data>> "error" swap at "not_found" = ] } 1&& ;
+ { [ couchdb-error? ] [ data>> "error" of "not_found" = ] } 1&& ;
: get-url ( url -- url' )
couchdb-auth-provider get
@@ -73,15 +73,15 @@ TUPLE: couchdb-auth-provider
over [ (reserve) ] [ 2drop t ] if ;
: unreserve ( couch-rval -- )
- [ "id" swap at get-url ]
- [ "rev" swap at "rev" set-query-param ]
+ [ "id" of get-url ]
+ [ "rev" of "rev" set-query-param ]
bi
couch-delete drop ;
: unreserve-from-id ( id -- )
[
get-url dup couch-get
- "_rev" swap at "rev" set-query-param
+ "_rev" of "rev" set-query-param
couch-delete drop
] [
dup is-couchdb-not-found-error? [ 2drop ] [ rethrow ] if
@@ -110,7 +110,7 @@ TUPLE: couchdb-auth-provider
! Should be given a view URL.
: ((get-user)) ( couchdb-url -- user/f )
couch-get
- "rows" swap at dup empty? [ drop f ] [ first "value" swap at ] if ;
+ "rows" of dup empty? [ drop f ] [ first "value" of ] if ;
: (get-user) ( username -- user/f )
couchdb-auth-provider get
@@ -171,8 +171,8 @@ TUPLE: couchdb-auth-provider
: unify-users ( old new -- new )
swap
- [ "_rev" swap at "_rev" rot set-at ]
- [ "_id" swap at "_id" rot set-at ]
+ [ "_rev" of "_rev" rot set-at ]
+ [ "_id" of "_id" rot set-at ]
[ swap assoc-union ]
2tri ;
@@ -182,15 +182,15 @@ TUPLE: couchdb-auth-provider
! (This word is called by the 'update-user' method.)
: check-update ( old new -- ? )
[
- 2dup [ "email" swap at ] same? not [
- [ "email" swap at ] bi@
+ 2dup [ "email" of ] same? not [
+ [ "email" of ] bi@
[ drop "email" reservation-id unreserve-from-id ]
[ nip "email" reserve ]
2bi
] [ 2drop t ] if
] [
- 2dup [ "username" swap at ] same? not [
- [ "username" swap at ] bi@
+ 2dup [ "username" of ] same? not [
+ [ "username" of ] bi@
[ drop "username" reservation-id unreserve-from-id ]
[ nip "username" reserve ]
2bi
@@ -217,7 +217,7 @@ M: couchdb-auth-provider new-user ( user provider -- user/f )
M: couchdb-auth-provider update-user ( user provider -- )
couchdb-auth-provider [
[ username>> (get-user)/throw-on-no-user dup ]
- [ drop "_id" swap at get-url ]
+ [ drop "_id" of get-url ]
[ user>user-hash swapd
2dup check-update drop
unify-users >json swap couch-put drop
@@ -11,7 +11,7 @@ CONSTANT: will
}
: please-stand-up ( assoc key -- value )
- swap at ;
+ of ;
[ t ] [ will the-real-slim-shady please-stand-up ] unit-test
[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test
@@ -15,7 +15,7 @@ IN: hashtables.identity.tests
[ 1001 ] [
SH{ } clone 1001 0 4 "asdf" <slice> pick set-at
- "asdf" swap at
+ "asdf" of
] unit-test
[ { { "asdf" 1000 } } ] [ SH{ { "asdf" 1000 } } >alist ] unit-test
@@ -29,10 +29,10 @@ TUPLE: html-sub-stream < html-writer style parent ;
[ data>> ] [ style>> ] [ parent>> ] tri ;
: object-link-tag ( xml style -- xml )
- presented swap at [ url-of [ simple-link ] when* ] when* ;
+ presented of [ url-of [ simple-link ] when* ] when* ;
: href-link-tag ( xml style -- xml )
- href swap at [ simple-link ] when* ;
+ href of [ simple-link ] when* ;
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
@@ -58,7 +58,7 @@ TUPLE: html-sub-stream < html-writer style parent ;
"font-family: " % % "; " % ;
MACRO: make-css ( pairs -- str )
- [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
+ [ '[ _ of [ _ execute ] when* ] ] { } assoc>map
'[ [ _ cleave ] "" make ] ;
: span-css-style ( style -- str )
@@ -81,7 +81,7 @@ MACRO: make-css ( pairs -- str )
"vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ;
: img-tag ( xml style -- xml )
- image swap at [ nip image-path simple-image ] when* ;
+ image of [ nip image-path simple-image ] when* ;
: format-html-span ( string style stream -- )
[
@@ -113,7 +113,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;"
{ border-color border-css, }
{ inset padding-css, }
} make-css
- ] [ wrap-margin swap at [ pre-css append ] unless ] bi
+ ] [ wrap-margin of [ pre-css append ] unless ] bi
" display: inline-block;" append ;
: div-tag ( xml style -- xml' )
View
@@ -222,5 +222,5 @@ TUPLE: post-data data params content-type content-encoding ;
: parse-content-type ( content-type -- type encoding )
";" split1
- parse-content-type-attributes "charset" swap at
+ parse-content-type-attributes "charset" of
[ dup mime-type-encoding encoding>name ] unless* ;
@@ -173,7 +173,7 @@ IN: io.launcher.windows.tests
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
- "A" swap at
+ "A" of
] unit-test
[ f ] [
@@ -185,7 +185,7 @@ IN: io.launcher.windows.tests
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
- "USERPROFILE" swap at "XXX" =
+ "USERPROFILE" of "XXX" =
] unit-test
2 [
@@ -240,4 +240,4 @@ IN: io.launcher.windows.tests
[ process>> command>> "asdfdontexistplzplz" = ]
[ process>> status>> f = ]
} 1&&
-] must-fail-with
+] must-fail-with
@@ -14,7 +14,7 @@ IN: linked-assocs.test
<linked-hash> 1 "b" pick set-at
2 "c" pick set-at
3 "a" pick set-at
- "c" swap at*
+ "c" ?of
] unit-test
{ { 2 3 4 } { "c" "a" "d" } 3 } [
@@ -103,7 +103,7 @@ IN: math.statistics.tests
V{ 2 5 8 }
} [
10 iota [ 3 mod ] collect-by
- [ 0 swap at ] [ 1 swap at ] [ 2 swap at ] tri
+ [ 0 of ] [ 1 of ] [ 2 of ] tri
] unit-test
[ 0 ] [ { 1 } { 1 } sample-cov ] unit-test
@@ -32,7 +32,7 @@ IN: mime.multipart.tests
[ t ] [
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
- "file1" swap at filename>> "up.txt" =
+ "file1" of filename>> "up.txt" =
] unit-test
SYMBOL: mime-test-server
@@ -81,7 +81,7 @@ ERROR: end-of-stream multipart ;
drop
] [
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
- [ content-disposition>> "name" swap at unquote ]
+ [ content-disposition>> "name" of unquote ]
[ mime-parts>> set-at ] tri
] if ;
@@ -555,14 +555,14 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
'ebnf' (parse) check-parse-result ast>> transform ;
: ebnf>quot ( string -- hashtable quot )
- parse-ebnf dup dup parser [ main swap at compile ] with-variable
+ parse-ebnf dup dup parser [ main of compile ] with-variable
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
PRIVATE>
SYNTAX: <EBNF
"EBNF>"
- reset-tokenizer parse-multiline-string parse-ebnf main swap at
+ reset-tokenizer parse-multiline-string parse-ebnf main of
suffix! reset-tokenizer ;
SYNTAX: [EBNF
@@ -78,7 +78,7 @@ SYMBOLS: combinator quotations ;
terminated? branch-variable ;
: terminate-branches ( seq -- )
- [ terminated? swap at ] all? [ terminate ] when ;
+ [ terminated? of ] all? [ terminate ] when ;
: compute-phi-function ( seq -- )
[ quotation active-variable sift quotations set ]
@@ -26,5 +26,5 @@ IN: tools.walker.debug
send-synchronous drop
p ?promise
- variables>> walker-continuation swap at
+ variables>> walker-continuation of
value>> data>> ;
@@ -23,8 +23,8 @@ DEFER: start-walker-thread
: get-walker-thread ( -- status continuation thread )
walker-thread tget [
- [ variables>> walker-status swap at ]
- [ variables>> walker-continuation swap at ]
+ [ variables>> walker-status of ]
+ [ variables>> walker-continuation of ]
[ ] tri
] [
f <model>
@@ -199,19 +199,19 @@ MEMO: specified-font ( assoc -- font )
#! We memoize here to avoid creating lots of duplicate font objects.
[ monospace-font <font> ] dip
{
- [ font-name swap at >>name ]
+ [ font-name of >>name ]
[
- font-style swap at {
+ font-style of {
{ f [ ] }
{ plain [ ] }
{ bold [ t >>bold? ] }
{ italic [ t >>italic? ] }
{ bold-italic [ t >>bold? t >>italic? ] }
} case
]
- [ font-size swap at >>size ]
- [ foreground swap at >>foreground ]
- [ background swap at >>background ]
+ [ font-size of >>size ]
+ [ foreground of >>foreground ]
+ [ background of >>background ]
} cleave
derive-font ;
@@ -31,7 +31,7 @@ TUPLE: weight primary secondary tertiary ignorable? ;
: help-one ( assoc key -- )
! Need to be more general? Not for DUCET, apparently
2 head 2dup swap key? [ 2drop ] [
- [ [ 1string swap at ] with { } map-as concat ]
+ [ [ 1string of ] with { } map-as concat ]
[ swap set-at ] 2bi
] if ;
@@ -92,7 +92,7 @@ PRIVATE>
: (chain-decomposed) ( hash value -- newvalue )
[
- 2dup swap at
+ 2dup of
[ (chain-decomposed) ] [ 1array nip ] ?if
] with map concat ;
@@ -63,12 +63,12 @@ IN: xml.elements
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-version ( alist -- version )
- T{ name { space "" } { main "version" } } swap at
+ T{ name { space "" } { main "version" } } of
[ good-version ] [ versionless-prolog ] if*
dup set-version ;
: prolog-encoding ( alist -- encoding )
- T{ name { space "" } { main "encoding" } } swap at
+ T{ name { space "" } { main "encoding" } } of
"UTF-8" or ;
: yes/no>bool ( string -- t/f )
@@ -79,7 +79,7 @@ IN: xml.elements
} case ;
: prolog-standalone ( alist -- version )
- T{ name { space "" } { main "standalone" } } swap at
+ T{ name { space "" } { main "standalone" } } of
[ yes/no>bool ] [ f ] if* ;
: prolog-attrs ( alist -- prolog )
@@ -72,7 +72,7 @@ SYNTAX: XML-NS:
DEFER: interpolate-sequence
: get-interpolated ( interpolated -- quot )
- var>> '[ [ _ swap at ] keep ] ;
+ var>> '[ [ _ of ] keep ] ;
: ?present ( object -- string )
dup [ present ] when ;
@@ -311,7 +311,7 @@ M: mark-previous-rule handle-rule-start
: tokenize-line ( line-context line rules -- line-context' seq )
[
- "MAIN" swap at -rot
+ "MAIN" of -rot
init-token-marker
mark-token-loop
mark-remaining
@@ -236,7 +236,7 @@ HELP: key?
{ $values { "key" object } { "assoc" assoc } { "?" boolean } }
{ $description "Tests if an assoc contains a key." } ;
-{ at at* key? ?at } related-words
+{ at at* key? ?at of ?of } related-words
HELP: at
{ $values { "key" object } { "assoc" assoc } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } }
@@ -246,6 +246,14 @@ HELP: ?at
{ $values { "key" object } { "assoc" assoc } { "value/key" "the value associated to the key, or the key if the key is not present in the assoc" } { "?" "a " { $link boolean } " indicating if the key was present" } }
{ $description "Looks up the value associated with a key. If the key was not present, an error can be thrown without extra stack shuffling. This word handles assocs that store " { $link f } "." } ;
+HELP: of
+{ $values { "assoc" assoc } { "key" object } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } }
+{ $description "Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to " { $link f } "; if the difference is important, use " { $link ?of } "." } ;
+
+HELP: ?of
+{ $values { "assoc" assoc } { "key" object } { "value/key" "the value associated to the key, or the key if the key is not present in the assoc" } { "?" "a " { $link boolean } " indicating if the key was present" } }
+{ $description "Looks up the value associated with a key. If the key was not present, an error can be thrown without extra stack shuffling. This word handles assocs that store " { $link f } "." } ;
+
HELP: assoc-each
{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... )" } } }
{ $description "Applies a quotation to each entry in the assoc." }
Oops, something went wrong.

0 comments on commit 38f1141

Please sign in to comment.