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 [ no-initial-value ]
  12     [ nip first dup word? [ initial-value* ] unless ] 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 members -- )
  22     [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
  23     [ define-variant-member swap add-mixin-instance ] with each ;
  24
  25 : parse-variant-tuple-member ( name -- member )
  26     create-class-in tuple
  27     "{" expect
  28     [ "}" parse-tuple-slots-delim ] { } make
  29     3array ;
  30
  31 : parse-variant-member ( name -- member )
  32     ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
  33
  34 : parse-variant-members ( -- members )
  35     [ scan dup ";" = not ]
  36     [ parse-variant-member ] produce nip ;
  37
  38 SYNTAX: VARIANT:
  39     CREATE-CLASS
  40     parse-variant-members
  41     define-variant-class ;
  42
  43 MACRO: unboa ( class -- )
  44     <wrapper> \ boa [ ] 2sequence [undo] ;
  45
  46 GENERIC# (match-branch) 1 ( class quot -- class quot' )
  47
  48 M: singleton-class (match-branch)
  49     \ drop prefix ;
  50 M: object (match-branch)
  51     over \ unboa [ ] 2sequence prepend ;
  52
  53 : ?class ( object -- class )
  54     dup word? [ class ] unless ;
  55
  56 MACRO: match ( branches -- )
  57     [ dup callable? [ first2 (match-branch) 2array ] unless ] map
  58     [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
  59