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