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