From db324a65ee95aea54e03c3c331c65fd016503977 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 18 Sep 2011 17:33:53 -0700
Subject: [PATCH] new vocab slots.macros: macro interface to slot accessors, as
 discussed in #134

---
 extra/slots/macros/authors.txt         |  1 +
 extra/slots/macros/macros-tests.factor | 75 ++++++++++++++++++++++++++
 extra/slots/macros/macros.factor       | 54 +++++++++++++++++++
 extra/slots/macros/summary.txt         |  1 +
 4 files changed, 131 insertions(+)
 create mode 100644 extra/slots/macros/authors.txt
 create mode 100644 extra/slots/macros/macros-tests.factor
 create mode 100644 extra/slots/macros/macros.factor
 create mode 100644 extra/slots/macros/summary.txt

diff --git a/extra/slots/macros/authors.txt b/extra/slots/macros/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/slots/macros/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/slots/macros/macros-tests.factor b/extra/slots/macros/macros-tests.factor
new file mode 100644
index 0000000000..082aa77f5d
--- /dev/null
+++ b/extra/slots/macros/macros-tests.factor
@@ -0,0 +1,75 @@
+! (c) 2011 Joe Groff bsd license
+USING: kernel math slots.macros tools.test ;
+IN: slots.macros.tests
+
+TUPLE: foo a b c ;
+
+{ 1 } [ T{ foo { a 1 } { b 2 } { c 3 } } "a" slot ] unit-test
+
+{ T{ foo { b 4 } } } [
+    foo new
+    [ 4 swap "b" set-slot ] keep
+] unit-test
+
+{ T{ foo { a 7 } { b 5 } { c 6 } } } [
+    foo new
+        5 "b" set-slot*
+        6 "c" set-slot*
+        7 "a" set-slot*
+] unit-test
+
+{ T{ foo { a 1 } { b 4 } { c 3 } } } [
+    T{ foo { a 1 } { b 2 } { c 3 } } clone
+    [ "b" [ 2 * ] change-slot ] keep
+] unit-test
+
+{ T{ foo { a 1/3 } { b 4 } { c 3 } } } [
+    T{ foo { a 1 } { b 2 } { c 3 } } clone
+    "b" [ 2 * ] change-slot*
+    "a" [ 3 / ] change-slot*
+] unit-test
+
+{ T{ foo { a 9 } { b 1 } } } [
+    T{ foo { a 8 } } clone
+    [ "a" inc-slot ]
+    [ "b" inc-slot ]
+    [ ] tri
+] unit-test
+
+{ T{ foo { a 12 } { b 3 } } } [
+    T{ foo { a 10 } } clone
+    [ 2 swap "a" slot+ ]
+    [ 3 swap "b" slot+ ]
+    [ ] tri
+] unit-test
+
+{ T{ foo { a V{ 1 2 } } { b V{ 3 } } } } [
+    foo new
+    V{ 1 } clone "a" set-slot*
+    [ 2 swap "a" push-slot ]
+    [ 3 swap "b" push-slot ]
+    [ ] tri
+] unit-test
+
+{ 2 1 3 } [
+    T{ foo { a 1 } { b 2 } { c 3 } }
+    { "b" "a" "c" } slots
+] unit-test
+
+{ { 2 1 3 } } [
+    T{ foo { a 1 } { b 2 } { c 3 } }
+    { "b" "a" "c" } {slots}
+] unit-test
+
+{ T{ foo { a "one" } { b "two" } { c "three" } } } [
+    "two" "one" "three"
+    T{ foo { a 1 } { b 2 } { c 3 } } clone
+    [ { "b" "a" "c" } set-slots ] keep
+] unit-test
+
+{ T{ foo { a "one" } { b "two" } { c "three" } } } [
+    { "two" "one" "three" }
+    T{ foo { a 1 } { b 2 } { c 3 } } clone
+    [ { "b" "a" "c" } {set-slots} ] keep
+] unit-test
+
diff --git a/extra/slots/macros/macros.factor b/extra/slots/macros/macros.factor
new file mode 100644
index 0000000000..d9f23ac5b8
--- /dev/null
+++ b/extra/slots/macros/macros.factor
@@ -0,0 +1,54 @@
+! (c) 2011 Joe Groff bsd license
+USING: combinators compiler.units fry generalizations kernel
+locals macros math quotations sequences sequences.generalizations
+slots vectors ;
+IN: slots.macros
+
+! Fundamental accessors
+
+<PRIVATE
+: define-slot ( name -- )
+    [ define-protocol-slot ] with-compilation-unit ;
+PRIVATE>
+
+MACRO: slot ( name -- quot: ( tuple -- value ) )
+    [ define-slot ] [ reader-word 1quotation ] bi ;
+MACRO: set-slot ( name -- quot: ( value tuple -- ) )
+    [ define-slot ] [ writer-word 1quotation ] bi ;
+
+
+! In-place modifiers akin to *-at or *-nth
+
+: change-slot ( ..a tuple name quot: ( ..a old -- ..b new ) -- ..b )
+    '[ slot @ ] [ set-slot ] 2bi ; inline
+
+: inc-slot ( tuple name -- )
+    [ 0 or 1 + ] change-slot ; inline
+
+: slot+ ( value tuple name -- )
+    [ 0 or + ] change-slot ; inline
+
+: push-slot ( value tuple name -- )
+    [ ?push ] change-slot ; inline
+
+! Chainable setters
+
+: set-slot* ( tuple value name -- tuple )
+    [ swap ] dip '[ _ set-slot ] keep ; inline
+
+: change-slot* ( tuple name quot: ( ..a old -- ..b new ) -- ..b tuple ) 
+    '[ _ _ change-slot ] keep ; inline
+
+! Multiple-slot accessors
+
+MACRO: slots ( names -- quot: ( tuple -- values... ) )
+    [ '[ _ slot ] ] { } map-as '[ _ cleave ] ;
+MACRO: {slots} ( names -- quot: ( tuple -- {values} ) )
+    dup length '[ _ slots _ narray ] ;
+
+MACRO: set-slots ( names -- quot: ( values... tuple -- ) )
+    [ [ '[ _ set-slot ] ] [ ] map-as ] [ length dup ] bi
+    '[ @ _ cleave-curry _ spread* ] ;
+
+MACRO: {set-slots} ( names -- quot: ( {values} tuple -- ) )
+    [ length ] keep '[ [ _ firstn ] dip _ set-slots ] ;
diff --git a/extra/slots/macros/summary.txt b/extra/slots/macros/summary.txt
new file mode 100644
index 0000000000..1ad9a2eba4
--- /dev/null
+++ b/extra/slots/macros/summary.txt
@@ -0,0 +1 @@
+Macro interface to accessors