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] =?utf8?q?r=C3=B4les?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
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 ;
+
+
-- 
2.34.1