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