/extra/variants/variants.factor

http://github.com/abeaumont/factor · Factor · 70 lines · 51 code · 18 blank · 1 comment · 11 complexity · 220cb91e26dd052052cc75f5d3e0efd2 MD5 · raw file

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