extra/multi-methods/multi-methods.factor

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