basis/delegate/delegate.factor

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