extra/variants/variants.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors arrays classes classes.mixin classes.parser
   3 classes.singleton classes.tuple classes.tuple.parser
   4 classes.union combinators inverse kernel lexer macros make
   5 parser quotations sequences slots splitting words ;
   6 IN: variants
   7
   8 PREDICATE: variant-class < mixin-class "variant?" word-prop ;
   9
  10 M: 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
  44 SYNTAX: VARIANT:
  45     scan-new-class
  46     parse-variant-members
  47     define-variant-class-members ;
  48
  49 SYNTAX: VARIANT-MEMBER:
  50     scan-word
  51     scan-token parse-variant-member
  52     define-variant-class-member ;
  53
  54 MACRO: unboa ( class -- )
  55     <wrapper> \ boa [ ] 2sequence [undo] ;
  56
  57 GENERIC# (match-branch) 1 ( class quot -- class quot' )
  58
  59 M: singleton-class (match-branch)
  60     \ drop prefix ;
  61 M: object (match-branch)
  62     over \ unboa [ ] 2sequence prepend ;
  63
  64 : ?class ( object -- class )
  65     dup word? [ class-of ] unless ;
  66
  67 MACRO: match ( branches -- )
  68     [ dup callable? [ first2 (match-branch) 2array ] unless ] map
  69     [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
  70