extra/visitor/visitor.factor

   1 USING: kernel generic.standard syntax words parser assocs
   2 generic quotations sequences effects arrays classes definitions
   3 prettyprint sorting prettyprint.backend shuffle ;
   4 IN: visitor
   5
   6 : define-visitor ( word -- )
   7     dup dup reset-word define-simple-generic
   8     dup H{ } clone "visitor-methods" set-word-prop
   9     H{ } clone "visitors" set-word-prop ;
  10
  11 : VISITOR:
  12     CREATE define-visitor ; parsing
  13
  14 : record-visitor ( top-class generic method-word -- )
  15     swap "visitors" word-prop swapd set-at ;
  16
  17 : define-1generic ( word -- )
  18     1 <standard-combination> define-generic ;
  19
  20 : copy-effect ( from to -- )
  21     swap stack-effect "declared-effect" set-word-prop ;
  22
  23 : new-vmethod ( method bottom-class top-class generic -- )
  24     gensym dup define-1generic
  25     2dup copy-effect
  26     3dup 1quotation -rot define-method
  27     [ record-visitor ] keep
  28     define-method ;
  29
  30 : define-visitor-method ( method bottom-class top-class generic -- )
  31     4dup >r 2array r> "visitor-methods" word-prop set-at
  32     2dup "visitors" word-prop at
  33     [ nip define-method ] [ new-vmethod ] ?if ;
  34
  35 : V:
  36     ! syntax: V: bottom-class top-class generic body... ;
  37     f set-word scan-word scan-word scan-word
  38     parse-definition -roll define-visitor-method ; parsing
  39
  40 ! see instance:
  41 ! see must be redone because "methods" doesn't show methods
  42
  43 PREDICATE: standard-generic visitor "visitors" word-prop ;
  44 PREDICATE: array triple length 3 = ;
  45 PREDICATE: triple visitor-spec
  46     first3 visitor? >r [ class? ] 2apply and r> and ;
  47
  48 M: visitor-spec definer drop \ V: \ ; ;
  49 M: visitor definer drop \ VISITOR: f ;
  50
  51 M: visitor-spec synopsis*
  52     ! same as method-spec#synopsis*
  53     dup definer drop pprint-word
  54     [ pprint-word ] each ;
  55
  56 M: visitor-spec definition
  57     first3 >r 2array r> "visitor-methods" word-prop at ;
  58
  59 M: visitor see
  60     dup (see)
  61     dup see-class
  62     dup "visitor-methods" word-prop keys natural-sort swap
  63     [ >r first2 r> 3array ] curry map see-all ;