diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor old mode 100644 new mode 100755 index ae40c85c0d..8da9e9dd69 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -20,7 +20,7 @@ HELP: object-slots HELP: mirror { $class-description "An associative structure which wraps an object and presents itself as a mapping from slot names to the object's slot values. Mirrors are used to build reflective developer tools." $nl -"Mirrors are mutable, however new keys cannot be inserted and keys cannot be deleted, only values of existing keys can be changed." +"Mirrors are mutable, however new keys cannot be inserted, only values of existing keys can be changed. Deleting a key has the effect of setting its value to " { $link f } "." $nl "Mirrors are created by calling " { $link } " or " { $link make-mirror } "." } ; @@ -33,7 +33,7 @@ HELP: "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." - "{ { circle-center { 100 50 } } { circle-radius 15 } }" + "{ { \"center\" { 100 50 } } { \"radius\" 15 } }" } } ; @@ -47,5 +47,5 @@ $nl "Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; HELP: make-mirror -{ $values { "obj" object } { "assoc" "an assoc" } } +{ $values { "obj" object } { "assoc" assoc } } { $description "Creates an assoc which reflects the internal structure of the object." } ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor old mode 100644 new mode 100755 index 863c4baa42..8f2964b19d --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -5,12 +5,12 @@ TUPLE: foo bar baz ; C: foo -[ { foo-bar foo-baz } ] [ 1 2 keys ] unit-test +[ { "bar" "baz" } ] [ 1 2 keys ] unit-test -[ 1 t ] [ \ foo-bar 1 2 at* ] unit-test +[ 1 t ] [ "bar" 1 2 at* ] unit-test [ f f ] [ "hi" 1 2 at* ] unit-test [ 3 ] [ - 3 \ foo-baz 1 2 [ set-at ] keep foo-baz + 3 "baz" 1 2 [ set-at ] keep foo-baz ] unit-test diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index af540ef86c..8f12bbb2f4 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -21,12 +21,14 @@ TUPLE: mirror object slots ; : >mirror< ( mirror -- obj slots ) dup mirror-object swap mirror-slots ; +: mirror@ ( slot-name mirror -- obj slot-spec ) + >mirror< swapd slot-named ; + M: mirror at* - >mirror< swapd slot-of-reader - dup [ slot-spec-offset slot t ] [ 2drop f f ] if ; + mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ; M: mirror set-at ( val key mirror -- ) - >mirror< swapd slot-of-reader dup [ + mirror@ dup [ dup slot-spec-writer [ slot-spec-offset set-slot ] [ @@ -42,7 +44,7 @@ M: mirror delete-at ( key mirror -- ) M: mirror >alist ( mirror -- alist ) >mirror< [ [ slot-spec-offset slot ] with map ] keep - [ slot-spec-reader ] map swap 2array flip ; + [ slot-spec-name ] map swap 2array flip ; M: mirror assoc-size mirror-slots length ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 40f0dd3da1..92d22247bd 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -110,3 +110,6 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ; : slot-of-writer ( writer specs -- spec/f ) [ slot-spec-writer eq? ] with find nip ; + +: slot-named ( string specs -- spec/f ) + [ slot-spec-name = ] with find nip ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor old mode 100644 new mode 100755 index 6fefb1b5dd..f14b766910 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -3,7 +3,7 @@ USING: new-slots html.elements http.server.validators accessors namespaces kernel io farkup math.parser assocs classes words tuples arrays sequences io.files -http.server.templating.fhtml splitting ; +http.server.templating.fhtml splitting mirrors ; IN: http.server.components SYMBOL: components @@ -94,14 +94,10 @@ M: number render-edit* M: number render-error* render-input render-error ; -: tuple>slots ( tuple -- alist ) - dup class "slot-names" word-prop swap tuple-slots - 2array flip ; - : with-components ( tuple components quot -- ) [ >r components set - dup tuple>slots values set + dup make-mirror values set tuple set r> call ] with-scope ; inline