basis/delegate/delegate.factor

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