basis/delegate/delegate.factor

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