/extra/variants/variants.factor

 1! (c)2009 Joe Groff bsd license
 2USING: accessors arrays classes classes.mixin classes.parser
 3classes.singleton classes.tuple classes.tuple.parser
 4classes.union combinators inverse kernel lexer macros make
 5parser quotations sequences slots splitting words ;
 6IN: variants
 7
 8PREDICATE: variant-class < mixin-class "variant?" word-prop ;
 9
10M: variant-class initial-value*
11    dup members [ drop f f ]
12    [ nip first dup word? [ t ] [ initial-value* ] if ] if-empty ;
13
14: define-tuple-class-and-boa-word ( class superclass slots -- )
15    pick [ define-tuple-class ] dip
16    dup name>> "<" ">" surround create-in swap define-boa-word ;
17
18: define-variant-member ( member -- class )
19    dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
20
21: define-variant-class ( class -- )
22    [ define-mixin-class ] [ t "variant?" set-word-prop ] bi ;
23
24: define-variant-class-member ( class member -- )
25    define-variant-member swap add-mixin-instance ;
26
27: define-variant-class-members ( class members -- )
28    [ dup define-variant-class ] dip
29    [ define-variant-class-member ] with each ;
30
31: parse-variant-tuple-member ( name -- member )
32    create-class-in tuple
33    "{" expect
34    [ "}" parse-tuple-slots-delim ] { } make
35    3array ;
36
37: parse-variant-member ( name -- member )
38    ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
39
40: parse-variant-members ( -- members )
41    [ scan-token dup ";" = not ]
42    [ parse-variant-member ] produce nip ;
43
44SYNTAX: VARIANT:
45    scan-new-class
46    parse-variant-members
47    define-variant-class-members ;
48
49SYNTAX: VARIANT-MEMBER:
50    scan-word
51    scan-token parse-variant-member
52    define-variant-class-member ;
53
54MACRO: unboa ( class -- )
55    <wrapper> \ boa [ ] 2sequence [undo] ;
56
57GENERIC# (match-branch) 1 ( class quot -- class quot' )
58
59M: singleton-class (match-branch)
60    \ drop prefix ;
61M: object (match-branch)
62    over \ unboa [ ] 2sequence prepend ;
63
64: ?class ( object -- class )
65    dup word? [ class-of ] unless ;
66
67MACRO: match ( branches -- )
68    [ dup callable? [ first2 (match-branch) 2array ] unless ] map
69    [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
70