From 345b27a67327d9db425b3c8f3f208105ef1121ab Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 25 Apr 2009 19:22:03 -0500
Subject: [PATCH 1/7] dog tag for pair-rocket

---
 extra/pair-rocket/pair-rocket-tests.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/extra/pair-rocket/pair-rocket-tests.factor b/extra/pair-rocket/pair-rocket-tests.factor
index 0e3d27beb1..695e50ea7e 100644
--- a/extra/pair-rocket/pair-rocket-tests.factor
+++ b/extra/pair-rocket/pair-rocket-tests.factor
@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
 USING: kernel pair-rocket tools.test ;
 IN: pair-rocket.tests
 

From 592a840c52ad322ef7cf2841e06ea02d1cfd7563 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 25 Apr 2009 19:22:47 -0500
Subject: [PATCH 2/7] a syntax pearl for literal string arrays

---
 extra/qw/authors.txt     |  1 +
 extra/qw/qw-docs.factor  | 11 +++++++++++
 extra/qw/qw-tests.factor |  5 +++++
 extra/qw/qw.factor       |  5 +++++
 extra/qw/summary.txt     |  1 +
 5 files changed, 23 insertions(+)
 create mode 100644 extra/qw/authors.txt
 create mode 100644 extra/qw/qw-docs.factor
 create mode 100644 extra/qw/qw-tests.factor
 create mode 100644 extra/qw/qw.factor
 create mode 100644 extra/qw/summary.txt

diff --git a/extra/qw/authors.txt b/extra/qw/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/qw/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor
new file mode 100644
index 0000000000..8af2c14f1e
--- /dev/null
+++ b/extra/qw/qw-docs.factor
@@ -0,0 +1,11 @@
+USING: help.markup help.syntax multiline ;
+IN: qw
+
+HELP: qw{
+{ $syntax "qw{ lorem ipsum }" }
+{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." }
+{ $examples
+{ $unchecked-example <" USING: prettyprint qw ;
+qw{ pop quiz my hive of big wild ex tranny jocks } . ">
+<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> }
+} ;
diff --git a/extra/qw/qw-tests.factor b/extra/qw/qw-tests.factor
new file mode 100644
index 0000000000..c9d9208751
--- /dev/null
+++ b/extra/qw/qw-tests.factor
@@ -0,0 +1,5 @@
+! (c)2009 Joe Groff bsd license
+USING: qw tools.test ;
+IN: qw.tests
+
+[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test
diff --git a/extra/qw/qw.factor b/extra/qw/qw.factor
new file mode 100644
index 0000000000..ce96587c92
--- /dev/null
+++ b/extra/qw/qw.factor
@@ -0,0 +1,5 @@
+! (c)2009 Joe Groff bsd license
+USING: lexer parser ;
+IN: qw
+
+SYNTAX: qw{ "}" parse-tokens parsed ;
diff --git a/extra/qw/summary.txt b/extra/qw/summary.txt
new file mode 100644
index 0000000000..8c31961dc8
--- /dev/null
+++ b/extra/qw/summary.txt
@@ -0,0 +1 @@
+Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar })

From a1fc4616e93dfa85cb991c7d0f9a446fcd312493 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 25 Apr 2009 19:24:01 -0500
Subject: [PATCH 3/7] dog tag again

---
 extra/qw/qw-docs.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor
index 8af2c14f1e..4709ef620d 100644
--- a/extra/qw/qw-docs.factor
+++ b/extra/qw/qw-docs.factor
@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
 USING: help.markup help.syntax multiline ;
 IN: qw
 

From e32869b0c305cfea8f932fc2856399aab04c26f0 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 25 Apr 2009 20:07:54 -0500
Subject: [PATCH 4/7] =?UTF-8?q?r=C3=B4les?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 extra/roles/roles-tests.factor | 55 +++++++++++++++++++++++++++
 extra/roles/roles.factor       | 69 ++++++++++++++++++++++++++++++++++
 2 files changed, 124 insertions(+)
 create mode 100644 extra/roles/roles-tests.factor
 create mode 100644 extra/roles/roles.factor

diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor
new file mode 100644
index 0000000000..aaa197f5ed
--- /dev/null
+++ b/extra/roles/roles-tests.factor
@@ -0,0 +1,55 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors classes.tuple compiler.units kernel qw roles sequences
+tools.test ;
+IN: roles.tests
+
+ROLE: fork tines ;
+ROLE: spoon bowl ;
+ROLE: instrument tone ;
+ROLE: tuning-fork <{ fork instrument } volume ;
+
+TUPLE: utensil handle ;
+
+! role consumption and tuple inheritance can be mixed
+TUPLE: foon <{ utensil fork spoon } ;
+TUPLE: tuning-spork <{ utensil spoon tuning-fork } ;
+
+! role class testing
+[ t ] [ fork role? ] unit-test
+[ f ] [ foon role? ] unit-test
+
+! roles aren't tuple classes by themselves and can't be instantiated
+[ f ] [ fork tuple-class? ] unit-test
+[ fork new ] must-fail
+
+! tuples which consume roles fall under their class
+[ t ] [ foon new fork? ] unit-test
+[ t ] [ foon new spoon? ] unit-test
+[ f ] [ foon new tuning-fork? ] unit-test
+[ f ] [ foon new instrument? ] unit-test
+
+[ t ] [ tuning-spork new fork? ] unit-test
+[ t ] [ tuning-spork new spoon? ] unit-test
+[ t ] [ tuning-spork new tuning-fork? ] unit-test
+[ t ] [ tuning-spork new instrument? ] unit-test
+
+! consumed role slots are placed in tuples in order
+[ qw{ handle tines bowl } ] [ foon all-slots [ name>> ] map ] unit-test
+[ qw{ handle bowl tines tone volume } ] [ tuning-spork all-slots [ name>> ] map ] unit-test
+
+! can't combine roles whose slots overlap
+ROLE: bong bowl ;
+SYMBOL: spong
+
+[ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ]
+[ role-slot-overlap? ] must-fail-with 
+
+[ [ spong { spoon bong } { } define-role ] with-compilation-unit ]
+[ role-slot-overlap? ] must-fail-with 
+
+! can't try to inherit multiple tuple classes
+TUPLE: tool blade ;
+SYMBOL: knife
+
+[ knife { utensil tool } { } define-tuple-class-with-roles ]
+[ multiple-inheritance-attempted? ] must-fail-with 
diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor
new file mode 100644
index 0000000000..f9ce808eb8
--- /dev/null
+++ b/extra/roles/roles.factor
@@ -0,0 +1,69 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays classes classes.mixin classes.parser
+classes.tuple classes.tuple.parser combinators
+combinators.short-circuit kernel lexer make parser sequences
+sets strings words ;
+IN: roles
+
+ERROR: role-slot-overlap class slots ;
+ERROR: multiple-inheritance-attempted classes ;
+
+PREDICATE: role < class
+    { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ;
+
+: parse-role-definition ( -- class superroles slots )
+    CREATE-CLASS scan {
+        { ";" [ { } { } ] }
+        { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
+        { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
+        [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
+    } case ;
+
+: slot-name ( name/array -- name )
+    dup string? [ ] [ first ] if ;
+: slot-names ( array -- names )
+    [ slot-name ] map ;
+
+: role-slots ( role -- slots )
+    [ "superroles" word-prop [ role-slots ] map concat ]
+    [ "role-slots" word-prop ] bi append ;
+
+: role-or-tuple-slot-names ( role-or-tuple -- names )
+    dup role?
+    [ role-slots slot-names ]
+    [ all-slots [ name>> ] map ] if ;
+
+: check-for-slot-overlap ( class roles-and-superclass slots -- )
+    [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
+    duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
+
+: roles>slots ( roles-and-superclass slots -- superclass slots' )
+    [
+        [ role? ] partition
+        dup length {
+            { 0 [ drop tuple ] }
+            { 1 [ first ] }
+            [ drop multiple-inheritance-attempted ]
+        } case
+        swap [ role-slots ] map concat
+    ] dip append ;
+
+: add-to-roles ( class roles -- )
+    [ add-mixin-instance ] with each ;
+
+: (define-role) ( class superroles slots -- )
+    [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry*
+    [ define-mixin-class ] tri ;
+
+: define-role ( class superroles slots -- )
+    [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ;
+
+: define-tuple-class-with-roles ( class roles-and-superclass slots -- )
+    [ check-for-slot-overlap ]
+    [ roles>slots define-tuple-class ]
+    [ drop [ role? ] filter add-to-roles ] 3tri ;
+
+SYNTAX: ROLE: parse-role-definition define-role ;
+SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;
+
+

From 32d2377df1f0799354e0d21bcae371e5d41d239b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 25 Apr 2009 20:18:45 -0500
Subject: [PATCH 5/7] test method dispatch on roles

---
 extra/roles/roles-tests.factor | 12 ++++++++++++
 1 file changed, 12 insertions(+)

diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor
index aaa197f5ed..fcbc20db16 100644
--- a/extra/roles/roles-tests.factor
+++ b/extra/roles/roles-tests.factor
@@ -53,3 +53,15 @@ SYMBOL: knife
 
 [ knife { utensil tool } { } define-tuple-class-with-roles ]
 [ multiple-inheritance-attempted? ] must-fail-with 
+
+! make sure method dispatch works
+GENERIC: poke ( pokee poker -- result )
+GENERIC: scoop ( scoopee scooper -- result )
+GENERIC: tune ( tunee tuner -- result )
+
+M: fork poke drop " got poked" append ;
+M: spoon scoop drop " got scooped" append ;
+M: instrument tune drop " got tuned" append ;
+
+[ "potato got poked" "potato got scooped" "potato got tuned" ]
+[ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test

From 81bef5d62c6f893110871211798168eb5b4f709b Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 25 Apr 2009 21:03:12 -0500
Subject: [PATCH 6/7] fix help lint for id3

---
 extra/id3/id3.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor
index 6025af4926..79df00ff5e 100644
--- a/extra/id3/id3.factor
+++ b/extra/id3/id3.factor
@@ -207,7 +207,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
 
 PRIVATE>
 
-: mp3>id3 ( path -- id3v2/f )
+: mp3>id3 ( path -- id3/f )
     [
         [ <id3> ] dip
         {

From 395e4267fd68142716861ec4468441092ddbfc28 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 25 Apr 2009 21:20:19 -0500
Subject: [PATCH 7/7] docs for roles

---
 extra/roles/authors.txt       |  1 +
 extra/roles/roles-docs.factor | 48 +++++++++++++++++++++++++++++++++++
 extra/roles/summary.txt       |  1 +
 3 files changed, 50 insertions(+)
 create mode 100644 extra/roles/authors.txt
 create mode 100644 extra/roles/roles-docs.factor
 create mode 100644 extra/roles/summary.txt

diff --git a/extra/roles/authors.txt b/extra/roles/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/roles/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/roles/roles-docs.factor b/extra/roles/roles-docs.factor
new file mode 100644
index 0000000000..412a7b8dcb
--- /dev/null
+++ b/extra/roles/roles-docs.factor
@@ -0,0 +1,48 @@
+! (c)2009 Joe Groff bsd license
+USING: classes.mixin help.markup help.syntax kernel multiline roles ;
+IN: roles
+
+HELP: ROLE:
+{ $syntax <" ROLE: name slots... ;
+ROLE: name < role slots... ;
+ROLE: name <{ roles... } slots... ; "> }
+{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "."
+$nl
+"Slot specifiers take one of the following three forms:"
+{ $list
+    { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
+    { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
+    { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
+}
+"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; 
+
+HELP: TUPLE:
+{ $syntax <" TUPLE: name slots ;
+TUPLE: name < estate slots ;
+TUPLE: name <{ estates... } slots... ; "> }
+{ $description "Defines a new " { $link tuple } " class."
+$nl
+"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "."
+$nl
+"Slot specifiers take one of the following three forms:"
+{ $list
+    { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
+    { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
+    { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
+}
+"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; 
+
+{
+    POSTPONE: ROLE:
+    POSTPONE: TUPLE:
+} related-words
+
+HELP: role
+{ $class-description "The superclass of all role classes. A " { $snippet "role" } " is a " { $link mixin-class } " that includes a set of slot definitions that can be added to " { $link tuple } " classes alongside other " { $snippet "role" } "s." } ;
+
+HELP: multiple-inheritance-attempted
+{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " definition attempts to inherit more than one " { $link tuple } " class." } ;
+
+HELP: role-slot-overlap
+{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ;
+
diff --git a/extra/roles/summary.txt b/extra/roles/summary.txt
new file mode 100644
index 0000000000..a14aae4838
--- /dev/null
+++ b/extra/roles/summary.txt
@@ -0,0 +1 @@
+Mixins for tuples