extra/multi-methods/multi-methods.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math sequences vectors classes classes.algebra
   4 combinators arrays words assocs parser namespaces definitions
   5 prettyprint prettyprint.backend quotations arrays.lib
   6 debugger io compiler.units kernel.private effects accessors
   7 hashtables sorting shuffle math.order sets ;
   8 IN: multi-methods
   9
  10 ! PART I: Converting hook specializers
  11 : canonicalize-specializer-0 ( specializer -- specializer' )
  12     [ \ f or ] map ;
  13
  14 SYMBOL: args
  15
  16 SYMBOL: hooks
  17
  18 SYMBOL: total
  19
  20 : canonicalize-specializer-1 ( specializer -- specializer' )
  21     [
  22         [ class? ] filter
  23         [ length <reversed> [ 1+ neg ] map ] keep zip
  24         [ length args [ max ] change ] keep
  25     ]
  26     [
  27         [ pair? ] filter
  28         [ keys [ hooks get adjoin ] each ] keep
  29     ] bi append ;
  30
  31 : canonicalize-specializer-2 ( specializer -- specializer' )
  32     [
  33         >r
  34         {
  35             { [ dup integer? ] [ ] }
  36             { [ dup word? ] [ hooks get index ] }
  37         } cond args get + r>
  38     ] assoc-map ;
  39
  40 : canonicalize-specializer-3 ( specializer -- specializer' )
  41     >r total get object <array> dup <enum> r> update ;
  42
  43 : canonicalize-specializers ( methods -- methods' hooks )
  44     [
  45         [ >r canonicalize-specializer-0 r> ] assoc-map
  46
  47         0 args set
  48         V{ } clone hooks set
  49
  50         [ >r canonicalize-specializer-1 r> ] assoc-map
  51
  52         hooks [ natural-sort ] change
  53
  54         [ >r canonicalize-specializer-2 r> ] assoc-map
  55
  56         args get hooks get length + total set
  57
  58         [ >r canonicalize-specializer-3 r> ] assoc-map
  59
  60         hooks get
  61     ] with-scope ;
  62
  63 : drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
  64
  65 : prepare-method ( method n -- quot )
  66     [ 1quotation ] [ drop-n-quot ] bi* prepend ;
  67
  68 : prepare-methods ( methods -- methods' prologue )
  69     canonicalize-specializers
  70     [ length [ prepare-method ] curry assoc-map ] keep
  71     [ [ get ] curry ] map concat [ ] like ;
  72
  73 ! Part II: Topologically sorting specializers
  74 : maximal-element ( seq quot -- n elt )
  75     dupd [
  76         swapd [ call +lt+ = ] 2curry filter empty?
  77     ] 2curry find [ "Topological sort failed" throw ] unless* ;
  78     inline
  79
  80 : topological-sort ( seq quot -- newseq )
  81     >r >vector [ dup empty? not ] r>
  82     [ dupd maximal-element >r over delete-nth r> ] curry
  83     [ ] unfold nip ; inline
  84
  85 : classes< ( seq1 seq2 -- lt/eq/gt )
  86     [
  87         {
  88             { [ 2dup eq? ] [ +eq+ ] }
  89             { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
  90             { [ 2dup class<= ] [ +lt+ ] }
  91             { [ 2dup swap class<= ] [ +gt+ ] }
  92             [ +eq+ ]
  93         } cond 2nip
  94     ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
  95
  96 : sort-methods ( alist -- alist' )
  97     [ [ first ] bi@ classes< ] topological-sort ;
  98
  99 ! PART III: Creating dispatch quotation
 100 : picker ( n -- quot )
 101     {
 102         { 0 [ [ dup ] ] }
 103         { 1 [ [ over ] ] }
 104         { 2 [ [ pick ] ] }
 105         [ 1- picker [ >r ] swap [ r> swap ] 3append ]
 106     } case ;
 107
 108 : (multi-predicate) ( class picker -- quot )
 109     swap "predicate" word-prop append ;
 110
 111 : multi-predicate ( classes -- quot )
 112     dup length <reversed>
 113     [ picker 2array ] 2map
 114     [ drop object eq? not ] assoc-filter
 115     dup empty? [ drop [ t ] ] [
 116         [ (multi-predicate) ] { } assoc>map
 117         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
 118     ] if ;
 119
 120 : argument-count ( methods -- n )
 121     keys 0 [ length max ] reduce ;
 122
 123 ERROR: no-method arguments generic ;
 124
 125 : make-default-method ( methods generic -- quot )
 126     >r argument-count r> [ >r narray r> no-method ] 2curry ;
 127
 128 : multi-dispatch-quot ( methods generic -- quot )
 129     [ make-default-method ]
 130     [ drop [ >r multi-predicate r> ] assoc-map reverse ]
 131     2bi alist>quot ;
 132
 133 ! Generic words
 134 PREDICATE: generic < word
 135     "multi-methods" word-prop >boolean ;
 136
 137 : methods ( word -- alist )
 138     "multi-methods" word-prop >alist ;
 139
 140 : make-generic ( generic -- quot )
 141     [
 142         [ methods prepare-methods % sort-methods ] keep
 143         multi-dispatch-quot %
 144     ] [ ] make ;
 145
 146 : update-generic ( word -- )
 147     dup make-generic define ;
 148
 149 ! Methods
 150 PREDICATE: method-body < word
 151     "multi-method-generic" word-prop >boolean ;
 152
 153 M: method-body stack-effect
 154     "multi-method-generic" word-prop stack-effect ;
 155
 156 M: method-body crossref?
 157     drop t ;
 158
 159 : method-word-name ( specializer generic -- string )
 160     [ word-name % "-" % unparse % ] "" make ;
 161
 162 : method-word-props ( specializer generic -- assoc )
 163     [
 164         "multi-method-generic" set
 165         "multi-method-specializer" set
 166     ] H{ } make-assoc ;
 167
 168 : <method> ( specializer generic -- word )
 169     [ method-word-props ] 2keep
 170     method-word-name f <word>
 171     [ set-word-props ] keep ;
 172
 173 : with-methods ( word quot -- )
 174     over >r >r "multi-methods" word-prop
 175     r> call r> update-generic ; inline
 176
 177 : reveal-method ( method classes generic -- )
 178     [ set-at ] with-methods ;
 179
 180 : method ( classes word -- method )
 181     "multi-methods" word-prop at ;
 182
 183 : create-method ( classes generic -- method )
 184     2dup method dup [
 185         2nip
 186     ] [
 187         drop [ <method> dup ] 2keep reveal-method
 188     ] if ;
 189
 190 : niceify-method [ dup \ f eq? [ drop f ] when ] map ;
 191
 192 M: no-method error.
 193     "Type check error" print
 194     nl
 195     "Generic word " write dup generic>> pprint
 196     " does not have a method applicable to inputs:" print
 197     dup arguments>> short.
 198     nl
 199     "Inputs have signature:" print
 200     dup arguments>> [ class ] map niceify-method .
 201     nl
 202     "Available methods: " print
 203     generic>> methods canonicalize-specializers drop sort-methods
 204     keys [ niceify-method ] map stack. ;
 205
 206 : forget-method ( specializer generic -- )
 207     [ delete-at ] with-methods ;
 208
 209 : method>spec ( method -- spec )
 210     [ "multi-method-specializer" word-prop ]
 211     [ "multi-method-generic" word-prop ] bi prefix ;
 212
 213 : define-generic ( word -- )
 214     dup "multi-methods" word-prop [
 215         drop
 216     ] [
 217         [ H{ } clone "multi-methods" set-word-prop ]
 218         [ update-generic ]
 219         bi
 220     ] if ;
 221
 222 ! Syntax
 223 : GENERIC:
 224     CREATE define-generic ; parsing
 225
 226 : parse-method ( -- quot classes generic )
 227     parse-definition [ 2 tail ] [ second ] [ first ] tri ;
 228
 229 : create-method-in ( specializer generic -- method )
 230     create-method dup save-location f set-word ;
 231
 232 : CREATE-METHOD
 233     scan-word scan-object swap create-method-in ;
 234
 235 : (METHOD:) CREATE-METHOD parse-definition ;
 236
 237 : METHOD: (METHOD:) define ; parsing
 238
 239 ! For compatibility
 240 : M:
 241     scan-word 1array scan-word create-method-in
 242     parse-definition
 243     define ; parsing
 244
 245 ! Definition protocol. We qualify core generics here
 246 USE: qualified
 247 QUALIFIED: syntax
 248
 249 syntax:M: generic definer drop \ GENERIC: f ;
 250
 251 syntax:M: generic definition drop f ;
 252
 253 PREDICATE: method-spec < array
 254     unclip generic? >r [ class? ] all? r> and ;
 255
 256 syntax:M: method-spec where
 257     dup unclip method [ ] [ first ] ?if where ;
 258
 259 syntax:M: method-spec set-where
 260     unclip method set-where ;
 261
 262 syntax:M: method-spec definer
 263     unclip method definer ;
 264
 265 syntax:M: method-spec definition
 266     unclip method definition ;
 267
 268 syntax:M: method-spec synopsis*
 269     unclip method synopsis* ;
 270
 271 syntax:M: method-spec forget*
 272     unclip method forget* ;
 273
 274 syntax:M: method-body definer
 275     drop \ METHOD: \ ; ;
 276
 277 syntax:M: method-body synopsis*
 278     dup definer.
 279     [ "multi-method-generic" word-prop pprint-word ]
 280     [ "multi-method-specializer" word-prop pprint* ] bi ;