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 io definitions
   4 sequences sequences.private assocs prettyprint.sections arrays ;
   5 IN: delegate
   6
   7 : define-protocol ( wordlist protocol -- )
   8     swap { } like "protocol-words" set-word-prop ;
   9
  10 : PROTOCOL:
  11     CREATE dup reset-generic dup define-symbol
  12     parse-definition swap define-protocol ; parsing
  13
  14 PREDICATE: word protocol "protocol-words" word-prop ;
  15
  16 GENERIC: group-words ( group -- words )
  17
  18 M: protocol group-words
  19     "protocol-words" word-prop ;
  20
  21 M: generic group-words
  22     1array ;
  23
  24 M: tuple-class group-words
  25     "slots" word-prop 1 tail ! The first slot is the delegate
  26     ! 1 tail should be removed when the delegate slot is removed
  27     dup [ slot-spec-reader ] map
  28     swap [ slot-spec-writer ] map append ;
  29
  30 : spin ( x y z -- z y x )
  31     swap rot ;
  32
  33 : define-consult-method ( word class quot -- )
  34     pick add <method> spin define-method ;
  35
  36 : define-consult ( class group quot -- )
  37     >r group-words r>
  38     swapd [ define-consult-method ] 2curry each ;
  39
  40 : CONSULT:
  41     scan-word scan-word parse-definition swapd define-consult ; parsing
  42
  43 PROTOCOL: sequence-protocol
  44     clone clone-like like new new-resizable nth nth-unsafe
  45     set-nth set-nth-unsafe length set-length lengthen ;
  46
  47 PROTOCOL: assoc-protocol
  48     at* assoc-size >alist assoc-find set-at
  49     delete-at clear-assoc new-assoc assoc-like ;
  50
  51 PROTOCOL: stream-protocol
  52     stream-close stream-read1 stream-read stream-read-until
  53     stream-flush stream-write1 stream-write stream-format
  54     stream-nl make-span-stream make-block-stream stream-readln
  55     make-cell-stream stream-write-table set-timeout ;
  56
  57 PROTOCOL: definition-protocol
  58     where set-where forget uses redefined*
  59     synopsis* definer definition ;
  60
  61 PROTOCOL: prettyprint-section-protocol
  62     section-fits? indent-section? unindent-first-line?
  63     newline-after?  short-section? short-section long-section
  64     <section> delegate>block add-section ;
  65
  66 : define-mimic ( group mimicker mimicked -- )
  67     >r >r group-words r> r> [
  68         pick "methods" word-prop at dup
  69         [ method-def <method> spin define-method ] [ 3drop ] if
  70     ] 2curry each ;
  71
  72 : MIMIC:
  73     scan-word scan-word scan-word define-mimic ; parsing