64 lines
1.9 KiB
Factor
64 lines
1.9 KiB
Factor
USING: kernel generic.standard syntax words parser assocs
|
|
generic quotations sequences effects arrays classes definitions
|
|
prettyprint sorting prettyprint.backend shuffle ;
|
|
IN: visitor
|
|
|
|
: define-visitor ( word -- )
|
|
dup dup reset-word define-simple-generic
|
|
dup H{ } clone "visitor-methods" set-word-prop
|
|
H{ } clone "visitors" set-word-prop ;
|
|
|
|
: VISITOR:
|
|
CREATE define-visitor ; parsing
|
|
|
|
: record-visitor ( top-class generic method-word -- )
|
|
swap "visitors" word-prop swapd set-at ;
|
|
|
|
: define-1generic ( word -- )
|
|
1 <standard-combination> define-generic ;
|
|
|
|
: copy-effect ( from to -- )
|
|
swap stack-effect "declared-effect" set-word-prop ;
|
|
|
|
: new-vmethod ( method bottom-class top-class generic -- )
|
|
gensym dup define-1generic
|
|
2dup copy-effect
|
|
3dup 1quotation -rot define-method
|
|
[ record-visitor ] keep
|
|
define-method ;
|
|
|
|
: define-visitor-method ( method bottom-class top-class generic -- )
|
|
4dup >r 2array r> "visitor-methods" word-prop set-at
|
|
2dup "visitors" word-prop at
|
|
[ nip define-method ] [ new-vmethod ] ?if ;
|
|
|
|
: V:
|
|
! syntax: V: bottom-class top-class generic body... ;
|
|
f set-word scan-word scan-word scan-word
|
|
parse-definition -roll define-visitor-method ; parsing
|
|
|
|
! see instance:
|
|
! see must be redone because "methods" doesn't show methods
|
|
|
|
PREDICATE: standard-generic visitor "visitors" word-prop ;
|
|
PREDICATE: array triple length 3 = ;
|
|
PREDICATE: triple visitor-spec
|
|
first3 visitor? >r [ class? ] 2apply and r> and ;
|
|
|
|
M: visitor-spec definer drop \ V: \ ; ;
|
|
M: visitor definer drop \ VISITOR: f ;
|
|
|
|
M: visitor-spec synopsis*
|
|
! same as method-spec#synopsis*
|
|
dup definer drop pprint-word
|
|
[ pprint-word ] each ;
|
|
|
|
M: visitor-spec definition
|
|
first3 >r 2array r> "visitor-methods" word-prop at ;
|
|
|
|
M: visitor see
|
|
dup (see)
|
|
dup see-class
|
|
dup "visitor-methods" word-prop keys natural-sort swap
|
|
[ >r first2 r> 3array ] curry map see-all ;
|