core/generic/generic.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.algebra
   4 classes.algebra.private classes.maybe classes.private
   5 combinators definitions kernel make namespaces sequences sets
   6 words ;
   7 FROM: namespaces => set ;
   8 IN: generic
   9
  10 ! Method combination protocol
  11 GENERIC: perform-combination ( word combination -- )
  12
  13 GENERIC: make-default-method ( generic combination -- method )
  14
  15 PREDICATE: generic < word
  16     "combination" word-prop >boolean ;
  17
  18 M: generic definition drop f ;
  19
  20 : make-generic ( word -- )
  21     [ { "unannotated-def" } reset-props ]
  22     [ dup "combination" word-prop perform-combination ]
  23     bi ;
  24
  25 PREDICATE: method < word
  26     "method-generic" word-prop >boolean ;
  27
  28 ERROR: method-lookup-failed class generic ;
  29
  30 : ?lookup-method ( class generic -- method/f )
  31     "methods" word-prop at ;
  32
  33 : lookup-method ( class generic -- method )
  34     2dup ?lookup-method [ 2nip ] [ method-lookup-failed ] if* ;
  35
  36 <PRIVATE
  37
  38 : interesting-class? ( class1 class2 -- ? )
  39     {
  40         ! Case 1: no intersection. Discard and keep going
  41         { [ 2dup classes-intersect? not ] [ 2drop t ] }
  42         ! Case 2: class1 contained in class2. Add to
  43         ! interesting set and keep going.
  44         { [ 2dup class<= ] [ nip , t ] }
  45         ! Case 3: class1 and class2 are incomparable. Give up
  46         [ 2drop f ]
  47     } cond ;
  48
  49 : interesting-classes ( class classes -- interesting/f )
  50     [ [ interesting-class? ] with all? ] { } make and ;
  51
  52 PRIVATE>
  53
  54 : method-classes ( generic -- classes )
  55     "methods" word-prop keys ;
  56
  57 : order ( generic -- seq )
  58     method-classes sort-classes ;
  59
  60 : nearest-class ( class generic -- class/f )
  61     method-classes interesting-classes smallest-class ;
  62
  63 : method-for-class ( class generic -- method/f )
  64     [ nip ] [ nearest-class ] 2bi dup [ swap ?lookup-method ] [ 2drop f ] if ;
  65
  66 GENERIC: effective-method ( generic -- method )
  67
  68 \ effective-method t "no-compile" set-word-prop
  69
  70 : next-method-class ( class generic -- class/f )
  71     method-classes [ class< ] with filter smallest-class ;
  72
  73 : next-method ( class generic -- method/f )
  74     [ next-method-class ] keep ?lookup-method ;
  75
  76 GENERIC: next-method-quot* ( class generic combination -- quot )
  77
  78 : next-method-quot ( method -- quot )
  79     next-method-quot-cache get [
  80         [ "method-class" word-prop ]
  81         [
  82             "method-generic" word-prop
  83             dup "combination" word-prop
  84         ] bi next-method-quot*
  85     ] cache ;
  86
  87 ERROR: no-next-method method ;
  88
  89 : (call-next-method) ( method -- )
  90     dup next-method-quot [ call ] [ no-next-method ] ?if ;
  91
  92 TUPLE: check-method class generic ;
  93
  94 : check-method ( classoid generic -- class generic )
  95     2dup [ classoid? ] [ generic? ] bi* and [
  96         \ check-method boa throw
  97     ] unless ; inline
  98
  99 : remake-generic ( generic -- )
 100     dup outdated-generics get set-in-unit ;
 101
 102 : remake-generics ( -- )
 103     outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
 104
 105 GENERIC: update-generic ( class generic -- )
 106
 107 : with-methods ( class generic quot -- )
 108     [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
 109
 110 GENERIC# method-word-name 1 ( class generic -- string )
 111
 112 M: class method-word-name ( class generic -- string )
 113     [ name>> ] bi@ "=>" glue ;
 114
 115 M: maybe method-word-name
 116     [ class>> name>> ] [ name>> ] bi* "=>" glue ;
 117
 118 M: method parent-word
 119     "method-generic" word-prop ;
 120
 121 M: method crossref?
 122     "forgotten" word-prop not ;
 123
 124 : method-word-props ( class generic -- assoc )
 125     [
 126         "method-generic" set
 127         "method-class" set
 128     ] H{ } make-assoc ;
 129
 130 : <method> ( class generic -- method )
 131     check-method
 132     [ method-word-name f <word> ] [ method-word-props ] 2bi
 133     >>props ;
 134
 135 GENERIC: implementor-classes ( obj -- class )
 136
 137 M: maybe implementor-classes class>> 1array ;
 138
 139 M: class implementor-classes 1array ;
 140
 141 M: anonymous-union implementor-classes members>> ;
 142
 143 M: anonymous-intersection implementor-classes participants>> ;
 144
 145 : with-implementors ( class generic quot -- )
 146     [ swap implementor-classes [ implementors-map get at ] map ] dip call ; inline
 147
 148 : reveal-method ( method classes generic -- )
 149     [ [ [ conjoin ] with each ] with-implementors ]
 150     [ [ set-at ] with-methods ]
 151     2bi ;
 152
 153 : create-method ( class generic -- method )
 154     2dup ?lookup-method dup [ 2nip dup reset-generic ] [
 155         drop
 156         [ <method> dup ] 2keep
 157         reveal-method
 158         reset-caches
 159     ] if ;
 160
 161 PREDICATE: default-method < word "default" word-prop ;
 162
 163 : <default-method> ( generic combination -- method )
 164     [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
 165     [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
 166
 167 : define-default-method ( generic combination -- )
 168     dupd <default-method> "default-method" set-word-prop ;
 169
 170 ! Definition protocol
 171 M: method definer
 172     drop \ M: \ ; ;
 173
 174 M: method forget*
 175     dup "forgotten" word-prop [ drop ] [
 176         [
 177             dup default-method? [ drop ] [
 178                 [
 179                     [ "method-class" word-prop ]
 180                     [ "method-generic" word-prop ] bi
 181                     2dup ?lookup-method
 182                 ] keep eq?
 183                 [
 184                     [ [ delete-at ] with-methods ]
 185                     [ [ [ delete-at ] with each ] with-implementors ] 2bi
 186                     reset-caches
 187                 ] [ 2drop ] if
 188             ] if
 189         ]
 190         [ call-next-method ] bi
 191     ] if ;
 192
 193 : define-generic ( word combination effect -- )
 194     [ nip swap set-stack-effect ]
 195     [
 196         drop
 197         2dup [ "combination" word-prop ] dip = [ 2drop ] [
 198             {
 199                 [ drop reset-generic ]
 200                 [ "combination" set-word-prop ]
 201                 [ drop H{ } clone "methods" set-word-prop ]
 202                 [ define-default-method ]
 203             }
 204             2cleave
 205         ] if
 206     ]
 207     [ 2drop remake-generic ] 3tri ;
 208
 209 M: generic subwords
 210     [
 211         [ "default-method" word-prop , ]
 212         [ "methods" word-prop values % ]
 213         [ "engines" word-prop % ]
 214         tri
 215     ] { } make ;
 216
 217 M: class forget-methods
 218     [ implementors ] [ [ swap ?lookup-method ] curry ] bi map forget-all ;