1 ! (c)2009 Joe Groff bsd license
2 USING: accessors arrays classes classes.mixin classes.parser
3 classes.tuple classes.tuple.parser combinators
4 combinators.short-circuit kernel lexer make parser sequences
8 ERROR: role-slot-overlap class slots ;
9 ERROR: multiple-inheritance-attempted classes ;
11 PREDICATE: role < mixin-class
12 "role-slots" word-prop >boolean ;
14 : parse-role-definition ( -- class superroles slots )
15 scan-new-class scan-token {
17 { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
18 { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
19 [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
22 : slot-name ( name/array -- name )
23 dup string? [ first ] unless ;
25 : slot-names ( array -- names )
28 : role-slots ( role -- slots )
29 [ "superroles" word-prop [ role-slots ] map concat ]
30 [ "role-slots" word-prop ] bi append ;
32 : role-or-tuple-slot-names ( role-or-tuple -- names )
34 [ role-slots slot-names ]
35 [ all-slots [ name>> ] map ] if ;
37 : check-for-slot-overlap ( class roles-and-superclass slots -- )
38 [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
39 duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
41 : roles>slots ( roles-and-superclass slots -- superclass slots' )
47 [ drop multiple-inheritance-attempted ]
49 swap [ role-slots ] map concat
52 : add-to-roles ( class roles -- )
53 [ add-mixin-instance ] with each ;
55 : (define-role) ( class superroles slots -- )
56 [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry*
57 [ define-mixin-class ] tri ;
59 : define-role ( class superroles slots -- )
60 [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ;
62 : define-tuple-class-with-roles ( class roles-and-superclass slots -- )
63 [ check-for-slot-overlap ]
64 [ roles>slots define-tuple-class ]
65 [ drop [ role? ] filter add-to-roles ] 3tri ;
67 SYNTAX: ROLE: parse-role-definition define-role ;
68 SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;