basis/delegate/delegate.factor

   1 ! Copyright (C) 2007, 2008 Daniel Ehrenberg
   2 ! Portions copyright (C) 2009 Slava Pestov
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors arrays assocs classes.tuple definitions generic
   5 generic.standard hashtables kernel lexer math parser
   6 generic.parser sequences sets slots words words.symbol fry
   7 compiler.units ;
   8 IN: delegate
   9
  10 <PRIVATE
  11
  12 : protocol-words ( protocol -- words )
  13     \ protocol-words word-prop ;
  14
  15 : protocol-consult ( protocol -- consulters )
  16     \ protocol-consult word-prop ;
  17
  18 GENERIC: group-words ( group -- words )
  19
  20 M: standard-generic group-words
  21     dup "combination" word-prop #>> 2array 1array ;
  22
  23 M: tuple-class group-words
  24     all-slots [
  25         name>>
  26         [ reader-word 0 2array ]
  27         [ writer-word 0 2array ] bi
  28         2array
  29     ] map concat ;
  30
  31 ! Consultation
  32
  33 TUPLE: consultation group class quot loc ;
  34
  35 : <consultation> ( group class quot -- consultation )
  36     f consultation boa ;
  37
  38 : create-consult-method ( word consultation -- method )
  39     [ class>> swap first create-method dup fake-definition ] keep
  40     [ drop ] [ "consultation" set-word-prop ] 2bi ;
  41
  42 PREDICATE: consult-method < method "consultation" word-prop ;
  43
  44 M: consult-method reset-word
  45     [ call-next-method ] [ f "consultation" set-word-prop ] bi ;
  46
  47 : consult-method-quot ( quot word -- object )
  48     [ second [ [ dip ] curry ] times ] [ first ] bi
  49     '[ _ call _ execute ] ;
  50
  51 : consult-method ( word consultation -- )
  52     [ create-consult-method ]
  53     [ quot>> swap consult-method-quot ] 2bi
  54     define ;
  55
  56 : change-word-prop ( word prop quot -- )
  57     [ swap props>> ] dip change-at ; inline
  58
  59 : each-generic ( consultation quot -- )
  60     [ [ group>> group-words ] keep ] dip curry each ; inline
  61
  62 : register-consult ( consultation -- )
  63     [ group>> \ protocol-consult ] [ ] [ class>> ] tri
  64     '[ [ _ _ ] dip ?set-at ] change-word-prop ;
  65
  66 : consult-methods ( consultation -- )
  67     [ consult-method ] each-generic ;
  68
  69 : unregister-consult ( consultation -- )
  70     [ class>> ] [ group>> ] bi
  71     \ protocol-consult word-prop delete-at ;
  72
  73 : unconsult-method ( word consultation -- )
  74     [ class>> swap first method ] keep
  75     over [
  76         over "consultation" word-prop eq?
  77         [ forget ] [ drop ] if
  78     ] [ 2drop ] if ;
  79
  80 : unconsult-methods ( consultation -- )
  81     [ unconsult-method ] each-generic ;
  82
  83 PRIVATE>
  84
  85 : define-consult ( consultation -- )
  86     [ register-consult ] [ consult-methods ] bi ;
  87
  88 SYNTAX: CONSULT:
  89     scan-word scan-word parse-definition <consultation>
  90     [ save-location ] [ define-consult ] bi ;
  91
  92 M: consultation where loc>> ;
  93
  94 M: consultation set-where (>>loc) ;
  95
  96 M: consultation forget*
  97     [ unconsult-methods ] [ unregister-consult ] bi ;
  98
  99 ! Protocols
 100 <PRIVATE
 101
 102 : forget-all-methods ( classes words -- )
 103     [ first method forget ] cartesian-each ;
 104
 105 : protocol-users ( protocol -- users )
 106     protocol-consult keys ;
 107
 108 : lost-words ( protocol wordlist -- lost-words )
 109     [ protocol-words ] dip diff ;
 110
 111 : forget-old-definitions ( protocol new-wordlist -- )
 112     [ drop protocol-users ] [ lost-words ] 2bi
 113     forget-all-methods ;
 114
 115 : added-words ( protocol wordlist -- added-words )
 116     swap protocol-words diff ;
 117
 118 : add-new-definitions ( protocol wordlist -- )
 119     [ drop protocol-consult values ] [ added-words ] 2bi
 120     [ swap consult-method ] cartesian-each ;
 121
 122 : initialize-protocol-props ( protocol wordlist -- )
 123     [
 124         drop \ protocol-consult
 125         [ H{ } assoc-like ] change-word-prop
 126     ] [ { } like \ protocol-words set-word-prop ] 2bi ;
 127
 128 : fill-in-depth ( wordlist -- wordlist' )
 129     [ dup word? [ 0 2array ] when ] map ;
 130
 131 : show-words ( wordlist' -- wordlist )
 132     [ dup second zero? [ first ] when ] map ;
 133
 134 PRIVATE>
 135
 136 : define-protocol ( protocol wordlist -- )
 137     [ drop define-symbol ] [
 138         fill-in-depth
 139         [ forget-old-definitions ]
 140         [ add-new-definitions ]
 141         [ initialize-protocol-props ] 2tri
 142     ] 2bi ;
 143
 144 SYNTAX: PROTOCOL:
 145     CREATE-WORD parse-definition define-protocol ;
 146
 147 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
 148
 149 M: protocol forget*
 150     [ f forget-old-definitions ] [ call-next-method ] bi ;
 151
 152
 153 M: protocol definition protocol-words show-words ;
 154
 155 M: protocol definer drop \ PROTOCOL: \ ; ;
 156
 157 M: protocol group-words protocol-words ;
 158
 159 SYNTAX: SLOT-PROTOCOL:
 160     CREATE-WORD ";" parse-tokens
 161     [ [ reader-word ] [ writer-word ] bi 2array ] map concat
 162     define-protocol ;