Merge branch 'master' of git://factorcode.org/git/factor

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
         {

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
 

extra/qw/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/qw/qw-docs.factor

@@ -0,0 +1,12 @@
+! (c)2009 Joe Groff bsd license
+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" } "> }
+} ;

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

extra/qw/qw.factor

@@ -0,0 +1,5 @@
+! (c)2009 Joe Groff bsd license
+USING: lexer parser ;
+IN: qw
+
+SYNTAX: qw{ "}" parse-tokens parsed ;

extra/qw/summary.txt

@@ -0,0 +1 @@
+Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar })

extra/roles/authors.txt

@@ -0,0 +1 @@
+Joe Groff

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." } ;
+

extra/roles/roles-tests.factor

@@ -0,0 +1,67 @@
+! (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 
+
+! 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

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 ;
+
+

extra/roles/summary.txt

@@ -0,0 +1 @@
+Mixins for tuples