basis/delegate/delegate.factor

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