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