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 generalizations
   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     [ ] produce 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     [ [ t ] ] [
 116         [ (multi-predicate) ] { } assoc>map
 117         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
 118     ] if-empty ;
 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     "forgotten" word-prop not ;
 158
 159 : method-word-name ( specializer generic -- string )
 160     [ 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     swap >>props ;
 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 ( seq -- seq )
 191     [ dup \ f eq? [ drop f ] when ] map ;
 192
 193 M: no-method error.
 194     "Type check error" print
 195     nl
 196     "Generic word " write dup generic>> pprint
 197     " does not have a method applicable to inputs:" print
 198     dup arguments>> short.
 199     nl
 200     "Inputs have signature:" print
 201     dup arguments>> [ class ] map niceify-method .
 202     nl
 203     "Available methods: " print
 204     generic>> methods canonicalize-specializers drop sort-methods
 205     keys [ niceify-method ] map stack. ;
 206
 207 : forget-method ( specializer generic -- )
 208     [ delete-at ] with-methods ;
 209
 210 : method>spec ( method -- spec )
 211     [ "multi-method-specializer" word-prop ]
 212     [ "multi-method-generic" word-prop ] bi prefix ;
 213
 214 : define-generic ( word -- )
 215     dup "multi-methods" word-prop [
 216         drop
 217     ] [
 218         [ H{ } clone "multi-methods" set-word-prop ]
 219         [ update-generic ]
 220         bi
 221     ] if ;
 222
 223 ! Syntax
 224 : GENERIC:
 225     CREATE define-generic ; parsing
 226
 227 : parse-method ( -- quot classes generic )
 228     parse-definition [ 2 tail ] [ second ] [ first ] tri ;
 229
 230 : create-method-in ( specializer generic -- method )
 231     create-method dup save-location f set-word ;
 232
 233 : CREATE-METHOD ( -- method )
 234     scan-word scan-object swap create-method-in ;
 235
 236 : (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
 237
 238 : METHOD: (METHOD:) define ; parsing
 239
 240 ! For compatibility
 241 : M:
 242     scan-word 1array scan-word create-method-in
 243     parse-definition
 244     define ; parsing
 245
 246 ! Definition protocol. We qualify core generics here
 247 USE: qualified
 248 QUALIFIED: syntax
 249
 250 syntax:M: generic definer drop \ GENERIC: f ;
 251
 252 syntax:M: generic definition drop f ;
 253
 254 PREDICATE: method-spec < array
 255     unclip generic? >r [ class? ] all? r> and ;
 256
 257 syntax:M: method-spec where
 258     dup unclip method [ ] [ first ] ?if where ;
 259
 260 syntax:M: method-spec set-where
 261     unclip method set-where ;
 262
 263 syntax:M: method-spec definer
 264     unclip method definer ;
 265
 266 syntax:M: method-spec definition
 267     unclip method definition ;
 268
 269 syntax:M: method-spec synopsis*
 270     unclip method synopsis* ;
 271
 272 syntax:M: method-spec forget*
 273     unclip method forget* ;
 274
 275 syntax:M: method-body definer
 276     drop \ METHOD: \ ; ;
 277
 278 syntax:M: method-body synopsis*
 279     dup definer.
 280     [ "multi-method-generic" word-prop pprint-word ]
 281     [ "multi-method-specializer" word-prop pprint* ] bi ;