extra/delegate/delegate.factor

   1 ! Copyright (C) 2007 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: parser generic kernel classes words slots assocs sequences arrays
   4 vectors definitions prettyprint combinators.lib math hashtables sets ;
   5 IN: delegate
   6
   7 : protocol-words ( protocol -- words )
   8     \ protocol-words word-prop ;
   9
  10 : protocol-consult ( protocol -- consulters )
  11     \ protocol-consult word-prop ;
  12
  13 GENERIC: group-words ( group -- words )
  14
  15 M: tuple-class group-words
  16     "slot-names" word-prop [
  17         [ reader-word ] [ writer-word ] bi
  18         2array [ 0 2array ] map
  19     ] map concat ;
  20
  21 ! Consultation
  22
  23 : consult-method ( word class quot -- )
  24     [ drop swap first create-method ]
  25     [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
  26
  27 : change-word-prop ( word prop quot -- )
  28     rot word-props swap change-at ; inline
  29
  30 : register-protocol ( group class quot -- )
  31     rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
  32
  33 : define-consult ( group class quot -- )
  34     [ register-protocol ] [
  35         rot group-words -rot
  36         [ consult-method ] 2curry each
  37     ] 3bi ;
  38
  39 : CONSULT:
  40     scan-word scan-word parse-definition define-consult ; parsing
  41
  42 ! Protocols
  43
  44 : cross-2each ( seq1 seq2 quot -- )
  45     [ with each ] 2curry each ; inline
  46
  47 : forget-all-methods ( classes words -- )
  48     [ 2array forget ] cross-2each ;
  49
  50 : protocol-users ( protocol -- users )
  51     protocol-consult keys ;
  52
  53 : lost-words ( protocol wordlist -- lost-words )
  54     >r protocol-words r> diff ;
  55
  56 : forget-old-definitions ( protocol new-wordlist -- )
  57     values [ drop protocol-users ] [ lost-words ] 2bi
  58     forget-all-methods ;
  59
  60 : added-words ( protocol wordlist -- added-words )
  61     swap protocol-words diff ;
  62
  63 : add-new-definitions ( protocol wordlist -- )
  64      dupd added-words >r protocol-consult >alist r>
  65      [ first2 consult-method ] cross-2each ;
  66
  67 : initialize-protocol-props ( protocol wordlist -- )
  68     [ drop H{ } clone \ protocol-consult set-word-prop ]
  69     [ { } like \ protocol-words set-word-prop ] 2bi ;
  70
  71 : fill-in-depth ( wordlist -- wordlist' )
  72     [ dup word? [ 0 2array ] when ] map ;
  73
  74 : define-protocol ( protocol wordlist -- )
  75     fill-in-depth
  76     [ forget-old-definitions ]
  77     [ add-new-definitions ]
  78     [ initialize-protocol-props ] 2tri ;
  79
  80 : PROTOCOL:
  81     CREATE-WORD
  82     [ define-symbol ]
  83     [ f "inline" set-word-prop ]
  84     [ parse-definition define-protocol ] tri ; parsing
  85
  86 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
  87
  88 M: protocol forget*
  89     [ f forget-old-definitions ] [ call-next-method ] bi ;
  90
  91 : show-words ( wordlist' -- wordlist )
  92     [ dup second zero? [ first ] when ] map ;
  93
  94 M: protocol definition protocol-words show-words ;
  95
  96 M: protocol definer drop \ PROTOCOL: \ ; ;
  97
  98 M: protocol synopsis* word-synopsis ; ! Necessary?
  99
 100 M: protocol group-words protocol-words ;