60 lines
1.8 KiB
Factor
60 lines
1.8 KiB
Factor
|
! (c)2009 Joe Groff bsd license
|
||
|
|
USING: accessors arrays classes classes.mixin classes.parser
|
||
|
|
classes.singleton classes.tuple classes.tuple.parser
|
||
|
|
classes.union combinators inverse kernel lexer macros make
|
||
|
|
parser quotations sequences slots splitting words ;
|
||
|
|
IN: variants
|
||
|
|
|
||
|
|
PREDICATE: variant-class < mixin-class "variant" word-prop ;
|
||
|
|
|
||
|
|
M: variant-class initial-value*
|
||
|
|
dup members [ no-initial-value ]
|
||
|
|
[ nip first dup word? [ initial-value* ] unless ] if-empty ;
|
||
|
|
|
||
|
|
: define-tuple-class-and-boa-word ( class superclass slots -- )
|
||
|
|
pick [ define-tuple-class ] dip
|
||
|
|
dup name>> "<" ">" surround create-in swap define-boa-word ;
|
||
|
|
|
||
|
|
: define-variant-member ( member -- class )
|
||
|
|
dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
|
||
|
|
|
||
|
|
: define-variant-class ( class members -- )
|
||
|
|
[ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
|
||
|
|
[ define-variant-member swap add-mixin-instance ] with each ;
|
||
|
|
|
||
|
|
: parse-variant-tuple-member ( name -- member )
|
||
|
|
create-class-in tuple
|
||
|
|
"{" expect
|
||
|
|
[ "}" parse-tuple-slots-delim ] { } make
|
||
|
|
3array ;
|
||
|
|
|
||
|
|
: parse-variant-member ( name -- member )
|
||
|
|
":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
|
||
|
|
|
||
|
|
: parse-variant-members ( -- members )
|
||
|
|
[ scan dup ";" = not ]
|
||
|
|
[ parse-variant-member ] produce nip ;
|
||
|
|
|
||
|
|
SYNTAX: VARIANT:
|
||
|
|
CREATE-CLASS
|
||
|
|
parse-variant-members
|
||
|
|
define-variant-class ;
|
||
|
|
|
||
|
|
MACRO: unboa ( class -- )
|
||
|
|
<wrapper> \ boa [ ] 2sequence [undo] ;
|
||
|
|
|
||
|
|
GENERIC# (match-branch) 1 ( class quot -- class quot' )
|
||
|
|
|
||
|
|
M: singleton-class (match-branch)
|
||
|
|
\ drop prefix ;
|
||
|
|
M: object (match-branch)
|
||
|
|
over \ unboa [ ] 2sequence prepend ;
|
||
|
|
|
||
|
|
: ?class ( object -- class )
|
||
|
|
dup word? [ class ] unless ;
|
||
|
|
|
||
|
|
MACRO: match ( branches -- )
|
||
|
|
[ dup callable? [ first2 (match-branch) 2array ] unless ] map
|
||
|
|
[ \ dup \ ?class ] dip \ case [ ] 4sequence ;
|
||
|
|
|