src/core/method.slate

   1
   2 m@(Method traits) do
   3 "Just runs the method without any inputs and answers the result."
   4 [m apply*].
   5
   6 m@(Method traits) applyWith: x
   7 "Applies the method to the one input."
   8 [m apply*, x].
   9
  10 m@(Method traits) applyWith: x with: y
  11 "Applies the method to 2 inputs."
  12 [m apply*, x, y].
  13
  14 m@(Method traits) applyWith: x with: y with: z
  15 "Applies the method to 3 inputs."
  16 [m apply*, x, y, z].
  17
  18 m@(Method traits) apply*
  19 "Applies the method to all available inputs. NB The Compiler optimizes this."
  20 [| *rest | m applyTo: rest].
  21
  22 s@(Symbol traits) sendWith: x
  23 [s sendTo: {x}].
  24
  25 s@(Symbol traits) sendWith: x with: y
  26 [s sendTo: {x. y}].
  27
  28 s@(Symbol traits) sendWith: x with: y with: z
  29 [s sendTo: {x. y. z}].
  30
  31 m@(Method traits) selector
  32 "By default, Methods are not named, so this answers Nil."
  33 [Nil].
  34
  35 m@(Method traits) isNamed
  36 "Answer whether the method has been defined with a dispatch signature."
  37 [m selector isNotNil].
  38
  39 m@(Closure traits) new [m clone].
  40 m@(Closure traits) arity [m method arity].
  41 m@(Closure traits) acceptsAdditionalArguments [m method acceptsAdditionalArguments].
  42 m@(Closure traits) allSelectorsSent [m method allSelectorsSent].
  43 m@(Closure traits) selector [m method selector].
  44 m@(Closure traits) optionalKeywords [m method optionalKeywords].
  45
  46 m@(CompiledMethod traits) arity
  47 "Uses the slot which declares the number of input variables to answer the
  48 method's arity."
  49 [m inputVariables].
  50
  51 m@(CompiledMethod traits) acceptsAdditionalArguments
  52 "Answers whether the method has a *rest paramter."
  53 [m restVariable].
  54
  55 _ define: selector@(Symbol traits) on: args as: m@(Method traits)
  56 "Provides Algol-style method definition syntax, like:
  57 function_name(args) {body}"
  58 [m asMethod: selector on: args].
  59
  60 m@(Method traits) replaceWith: newM on: args
  61 "Uninstall the given method from the arguments, which need to be those holding
  62 the actual role entries pointing to that method for dispatch, and then define
  63 the new Method on those same arguments."
  64 [
  65   m removeFrom: args.
  66   newM asMethod: m selector on: args
  67 ].
  68
  69 _@(Method traits) findNamed: selector on: args
  70 "Answer the method found through dispatch with the given name on the arguments."
  71 [selector findOn: args].
  72
  73 name@(Symbol traits) isFoundOn: args
  74 "Answer whether a method with the given name is applicable to the arguments."
  75 [
  76   (name findOn: args) isNotNil
  77 ].
  78
  79 name@(Symbol traits) removeMethodFrom: args &ifNotFound: block
  80 "Removes the method with the given selector from the arguments."
  81 [
  82   block `defaultsTo: [name notFoundOn: args].
  83   (name findOn: args)
  84     ifNil: block
  85     ifNotNilDo: #(removeFrom: args) `er
  86 ].
  87
  88 name@(Symbol traits) findsSameMethodOn: args1 asOn: args2
  89 "Answers whether lookup returns the exact same method for two different
  90 signatures.
  91 This also handles failed lookup, where Nil is returned from findOn:."
  92 [
  93   (name findOn: args1)
  94     ifNil: [False]
  95     ifNotNilDo: [| :m1 | (name findOn: args2)
  96                            ifNil: [False] ifNotNilDo: #(= m1) `er]
  97 ].
  98
  99 name@(Symbol traits) alias: selector on: args
 100 "Creates a method that just sends the given selector on the specified
 101 arguments."
 102 [
 103   name arity = selector arity
 104     ifTrue: [(nodes Literal for: selector) er evaluate asMethod: name on: args]
 105     ifFalse: [error: 'The selector names do not match.']
 106 ].
 107
 108 name@(Symbol traits) delegateTo: attribute on: args
 109 "Creates a method that just sends the given selector to the attribute
 110 of the first argument."
 111 [name delegateTo: attribute at: 0 on: args].
 112
 113 name@(Symbol traits) delegateTo: attribute at: roleIndex on: args
 114 "Creates a method that just sends the given selector to the attribute
 115 of the argument at the specified index."
 116 [
 117   src ::= (nodes Literal for: name) er.
 118   src statements first arguments at: roleIndex infect:
 119     [| :arg | nodes UnaryMessage sending: attribute to: {arg}].
 120   src evaluate asMethod: name on: args
 121 ].
 122
 123 x@(Root traits) perform: selector
 124 "Included for Smalltalk-80 compatibility and brevity."
 125 [selector sendTo: {x}].
 126
 127 condition@(Method traits) whileTrue: body
 128 "Repeatedly execute the body block after checking each time that the condition
 129 block returns True."
 130 [
 131   [condition do ifFalse: [^ Nil].
 132    body do] loop
 133 ].
 134
 135 condition@(Method traits) whileTrue
 136 "Repeatedly execute the block until it returns False. Naturally the point is
 137 usually that the body before the last statement has some kind of side-effect
 138 or other computation that updates, or relies on external state to affect the
 139 condition."
 140 [
 141   condition whileTrue: []
 142 ].
 143
 144 condition@(Method traits) whileFalse: body
 145 "Repeatedly execute the body block after checking each time that the condition
 146 block returns False."
 147 [
 148   [condition do ifTrue: [^ Nil].
 149    body do] loop
 150 ].
 151
 152 condition@(Method traits) whileFalse
 153 "Repeatedly execute the block until it returns True. Naturally the point is
 154 usually that the body before the last statement has some kind of side-effect
 155 or other computation that updates, or relies on external state to affect the
 156 condition."
 157 [
 158   condition whileFalse: []
 159 ].
 160
 161 body@(Method traits) loop
 162 "Execute the block repeatedly, until control is thrown outside by the block
 163 itself. This relies on the byte-compiler's transformation of loop calls with
 164 methods to a lower-level control-flow implementation."
 165 [[body do. ] loop].
 166
 167 _@(Root traits) if: boolean then: trueBlock
 168 [boolean ifTrue: trueBlock].
 169
 170 _@(Root traits) if: boolean then: trueBlock else: falseBlock
 171 [boolean ifTrue: trueBlock ifFalse: falseBlock].
 172
 173 body@(Method traits) while: testBlock
 174 "Evaluates the body block once, and then again as long as the testBlock
 175 returns True, and returns the last return value of the body."
 176 [| result |
 177   [result := body do.
 178    testBlock do] whileTrue.
 179   result
 180 ].
 181
 182 body@(Method traits) until: testBlock
 183 "Evaluates the body block once, and then again as long as the testBlock
 184 returns False, and returns the last return value of the body."
 185 [| result |
 186   [result := body do.
 187    testBlock do] whileFalse.
 188   result
 189 ].
 190
 191 m@(Method traits) unless: boolean
 192 "Evaluates the block body if the given condition is False."
 193 [boolean ifFalse: [m do]].
 194
 195 m@(Method traits) if: boolean
 196 "Evaluates the block body if the given condition is True."
 197 [boolean ifTrue: [m do]].
 198
 199 m@(Method traits) for: src
 200 "Evaluates the block for each element of the Enumerable (Collection or Stream)."
 201 [src do: m].
 202
 203 count@(Integer traits) timesRepeat: block
 204 "Execute the block the number of times of the count, answering Nil."
 205 [
 206   [count > 0]
 207     whileTrue:
 208       [block do.
 209        count: count - 1]
 210 ].
 211
 212 start@(Integer traits) to: end do: block
 213 "Auto-detects the direction of the progression."
 214 [
 215   start < end
 216     ifTrue: [start upTo: end do: block]
 217     ifFalse: [start downTo: end do: block]
 218 ].
 219
 220 start@(Integer traits) upTo: end do: block
 221 "Executes the block with each Integer from the start ascending by 1 to the end."
 222 [
 223   [start <= end]
 224     whileTrue:
 225       [block applyWith: start.
 226        start: start + 1]
 227 ].
 228
 229 start@(Integer traits) below: end do: block
 230 "Executes the block with each Integer from the start descending by 1 to
 231 just before the end."
 232 [
 233   [start < end]
 234     whileTrue:
 235       [block applyWith: start.
 236        start: start + 1]
 237 ].
 238
 239 start@(Integer traits) downTo: end do: block
 240 "Executes the block with each Integer from the start descending by 1 to the
 241 end."
 242 [
 243   [start >= end]
 244     whileTrue:
 245       [block applyWith: start.
 246        start: start - 1]
 247 ].
 248
 249 start@(Integer traits) above: end do: block
 250 "Executes the block with each Integer from the start ascending by 1 to
 251 just before the end."
 252 [
 253   [start > end]
 254     whileTrue:
 255       [block applyWith: start.
 256        start: start - 1]
 257 ].
 258
 259 start@(Number traits) downTo: end by: inc do: block
 260 "Executes the block with each Integer from the start descending by the
 261 increment to the end."
 262 [
 263   [start >= end]
 264     whileTrue:
 265       [block applyWith: start.
 266        start: start - inc]
 267 ].
 268
 269 start@(Number traits) above: end by: inc do: block
 270 "Executes the block with each Integer from the start descending by the
 271 increment to just before the end."
 272 [
 273   start downTo: end + 1 by: inc do: block
 274 ].
 275
 276 start@(Number traits) upTo: end by: inc do: block
 277 "Executes the block with each Integer from the start ascending by the increment
 278 to the end."
 279 [
 280   [start <= end]
 281     whileTrue:
 282       [block applyWith: start.
 283        start: start + inc]
 284 ].
 285
 286 start@(Number traits) below: end by: inc do: block
 287 "Executes the block with each Integer from the start descending by the increment
 288 to just before the end."
 289 [
 290   start upTo: end - 1 by: inc do: block
 291 ].
 292
 293 m@(Method traits) new
 294 [ m clone ].
 295
 296 _@(Method traits) newAlwaysReturning: obj
 297 "Answers a new block which takes an argument and ignores it, returning the
 298 one (constant) object it was created for."
 299 [
 300   [| *_ | obj]
 301 ].
 302
 303 "Additional overrides for /\ and \/ for lazy-evaluated conditionals:"
 304
 305 _@True /\ block@(Method traits) [block do].
 306 _@False /\ _@(Method traits) [False].
 307 _@True \/ _@(Method traits) [True].
 308 _@False \/ block@(Method traits) [block do].
 309
 310 m@(Method traits) ifCompletes: successBlock ifFails: errorBlock
 311 "Executes the first method, and then executes either the successBlock or the
 312 errorBlock depending on whether there is a non-local exit that prevents the
 313 first from completing normally."
 314 [| exitedNormally |
 315   exitedNormally := False.
 316   [result ::= m do. exitedNormally := True. result]
 317     ensure: [exitedNormally ifTrue: [successBlock do] ifFalse: [errorBlock do]]
 318 ].
 319
 320 m@(Method traits) unlessCompletes: errorBlock
 321 "Executes the first Method, and executes the second method only if there
 322 is a non-local exit so that the first does not complete normally."
 323 [m ifCompletes: [] ifFails: errorBlock].
 324
 325 m@(Method traits) ifCompletes: successBlock
 326 "Executes the first Method, and executes the second method only if there
 327 is no non-local exit so that the first completes normally."
 328 [m ifCompletes: successBlock ifFails: []].
 329
 330 _@(Root traits) withBreakerDo: m@(Method traits)
 331 "Allows implementation of single-level block return (as opposed to full
 332 lexical return which is default) by passing as the argument a block which
 333 will return from this wrapper when invoked."
 334 [m applyWith: [^ Nil]].
 335
 336 m@(Method traits) ** n@(Method traits)
 337 "Answers a new Method whose effect is that of calling the first method
 338 on the results of the second method applied to whatever arguments are passed.
 339 This composition is associative, i.e. (a ** b) ** c = a ** (b ** c).
 340 When the second method, n, does not take a *rest option or the first takes
 341 more than one input, then the output is chunked into groups for its
 342 consumption. E.g.:
 343 #; `er ** #; `er apply*, 'a', 'b', 'c', 'd' => 'abcd'
 344 #; `er ** #name `er apply*, #a, #/ => 'a/'"
 345 [
 346   n acceptsAdditionalArguments \/ [m arity = 1]
 347     ifTrue:
 348       [[| *args | m apply*, (n applyTo: args)]]
 349     ifFalse:
 350       [[| *args |
 351         m applyTo:
 352           ([| :stream |
 353              args do: [| *each | stream nextPut: (n applyTo: each)]
 354                   inGroupsOf: n arity] writingAs: #{})]]
 355 ].
 356
 357 #**`er asMethod: #compose: on: {Method traits. Method traits}.
 358 "A named alias for **."
 359
 360 i@(Root traits) converge: block
 361 "Apply block to i until it returns the previously returned value or
 362 the original value. In other words, until no change happens anymore or
 363 we're back at the beginning.
 364 NOTE: The originality test is used to avoid endless loop. It's
 365 possible to construct blocks that don't always return the same
 366 value for same input, so should there be another converge without this
 367 test?"
 368 [| current last |
 369   current := block applyWith: i.
 370   [{i. last} includes: current] whileFalse:
 371     [last := current.
 372      current := block applyWith: current].
 373   current
 374 ].
 375
 376 "Adverb operators:" (
 377
 378 m@(Method traits) reducer
 379 "Over in K"
 380 [#(reduce: m) `er].
 381
 382 m@(Method traits) collecter
 383 "Each in K"
 384 [#(collect: m) `er].
 385
 386 m@(Method traits) acrosser
 387 "Rename me"
 388 [#(m across: _) `er].
 389
 390 m@(Method traits) tracer
 391 "Scan or trace in K."
 392 [#(trace: m) `er].
 393
 394 m@(Method traits) selecter
 395 [#(select: m) `er].
 396
 397 m@(Method traits) injecter
 398 "Over dyad in K"
 399 [[| :arg1 :arg2 | arg2 inject: arg1 into: m]].
 400
 401 m@(Method traits) converger
 402 [#(converge: m) `er].
 403
 404 m@(Method traits) applier
 405 [#(m applyTo: _) `er].
 406
 407 ).
 408
 409 m@(Method traits) fill: arg with: val
 410 "Answer a new method based on the given one, with the argument at a given index
 411 filled in with a value, essentially currying the method."
 412 [
 413   (arg between: 0 and:
 414     (m acceptsAdditionalArguments ifTrue: [PositiveInfinity] ifFalse: [m arity - 1]))
 415     ifFalse: [error: 'Attempted to fill nonexistent method argument.'].
 416   [| *args | m applyTo: (args copyWith: val at: arg)]
 417 ].
 418
 419 m@(Method traits) <-* val
 420 [
 421   [| *args | m applyTo: (args copyWith: val)]
 422 ].
 423
 424 Method traits Identity ::= [| :x | x].
 425 "The method Identity does nothing but return its sole argument."
 426
 427 Method traits Y ::=
 428   [| :f | [| :x | f applyWith: (x applyWith: x)]
 429      applyWith: [| :x | f applyWith: (x applyWith: x)]].
 430 "The Y recursion combinator - also known as the fixed-point combinator, since
 431 it computes the fixed point of any single-argument Method it is applied with.
 432 The core property is that (f applyWith: (Y applyWith: f)) = (Y applyWith: f)
 433 for any method f. The practical use is allowing the definition of anonymous
 434 recursive Methods from Methods which define the individual step (and take an
 435 extra argument which is the Method to recurse on when appropriate)."
 436
 437 Method traits define: #SequentialComposition &parents: {Method} &slots: {#methods -> #{}}.
 438
 439 "A Method's SequentialComposition takes several methods with compatible
 440 signatures and applies them in order to the same arguments."
 441
 442 mc@(Method SequentialComposition traits) newForAll: c
 443 [mc clone `>> [methods := c as: mc methods. ]].
 444
 445 mc@(Method SequentialComposition traits) applyTo: args
 446 [mc contents do: #applyTo: `er <-* args].
 447
 448 Method traits define: #Converse &parents: {Method} &slots: {#method -> []}.
 449 "A Method's converse takes the arguments in reverse to produce the same
 450 result. This implementation works on any method arity, but the client needs
 451 to be aware of this arity, naturally."
 452
 453 m@(Method traits) converse
 454 "Answers a new converse of the given method."
 455 [m Converse cloneSettingSlots: #{#method} to: {m}].
 456
 457 mc@(Method Converse traits) arity
 458 "The arity is inherited from the inner method."
 459 [mc method arity].
 460
 461 mc@(Method Converse traits) allSelectorsSent
 462 "The selectors sent is inherited from the inner method."
 463 [mc method allSelectorsSent].
 464
 465 mc@(Method Converse traits) converse
 466 "A converse of a converse is the original method."
 467 [mc method].
 468
 469 mc@(Method Converse traits) do
 470 [mc method do].
 471
 472 mc@(Method Converse traits) applyWith: obj
 473 [mc method applyWith: obj].
 474
 475 mc@(Method Converse traits) applyWith: obj1 with: obj2
 476 [mc method applyWith: obj2 with: obj1].
 477
 478 mc@(Method Converse traits) applyWith: obj1 with: obj2 with: obj3
 479 [mc method applyWith: obj3 with: obj2 with: obj1].
 480
 481 mc@(Method Converse traits) applyTo: array
 482 [mc method applyTo: array reversed].
 483
 484 m@(Method traits) swing
 485 "This is a higher-order function which does a reverse distribution of sorts.
 486 It was ported from:
 487 - http://www.haskell.org/hawiki/LicensedPreludeExts
 488 - http://www.haskell.org/haskellwiki/Pointfree#Swing
 489 Example: collect: takes a collection of objects and a method,
 490   #collect:`er swing takes an object and a collection of methods.
 491 TODO: Improve the documentation, and add examples."
 492 [
 493   m arity = 2
 494     ifTrue: [[| :b :a | m apply*, a, [| :g | g apply*, b]]]
 495     ifFalse:
 496       [TODO: 'Implement multi-argument swing.'
 497        "[| *args | m applyTo: {args last} ; args allButLast reversed]"]
 498 ].