/extra/variants/variants.factor
http://github.com/abeaumont/factor · Factor · 70 lines · 51 code · 18 blank · 1 comment · 11 complexity · 220cb91e26dd052052cc75f5d3e0efd2 MD5 · raw file
- ! (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 [ drop f f ]
- [ nip first dup word? [ t ] [ initial-value* ] if ] 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 -- )
- [ define-mixin-class ] [ t "variant?" set-word-prop ] bi ;
- : define-variant-class-member ( class member -- )
- define-variant-member swap add-mixin-instance ;
- : define-variant-class-members ( class members -- )
- [ dup define-variant-class ] dip
- [ define-variant-class-member ] 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-token dup ";" = not ]
- [ parse-variant-member ] produce nip ;
- SYNTAX: VARIANT:
- scan-new-class
- parse-variant-members
- define-variant-class-members ;
- SYNTAX: VARIANT-MEMBER:
- scan-word
- scan-token parse-variant-member
- define-variant-class-member ;
- 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-of ] unless ;
- MACRO: match ( branches -- )
- [ dup callable? [ first2 (match-branch) 2array ] unless ] map
- [ \ dup \ ?class ] dip \ case [ ] 4sequence ;