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) doIn: env
 337 "Executes the method without arguments, but having the environment set
 338 to the given one. This is non-reentrant, though, because the environment
 339 slot is per-method-object, not per-activation."
 340 [| prevEnv |
 341   prevEnv := m environment.
 342   [m do] ensure: [m environment := prevEnv]
 343 ].
 344
 345 _@(Root traits) in: env do: m@(Method traits)
 346 "Aliases doIn: for convenient expression."
 347 [m doIn: env].
 348
 349 m@(Method traits) ** n@(Method traits)
 350 "Answers a new Method whose effect is that of calling the first method
 351 on the results of the second method applied to whatever arguments are passed.
 352 This composition is associative, i.e. (a ** b) ** c = a ** (b ** c).
 353 When the second method, n, does not take a *rest option or the first takes
 354 more than one input, then the output is chunked into groups for its
 355 consumption. E.g.:
 356 #; `er ** #; `er apply*, 'a', 'b', 'c', 'd' => 'abcd'
 357 #; `er ** #name `er apply*, #a, #/ => 'a/'"
 358 [
 359   n acceptsAdditionalArguments \/ [m arity = 1]
 360     ifTrue:
 361       [[| *args | m apply*, (n applyTo: args)]]
 362     ifFalse:
 363       [[| *args |
 364         m applyTo:
 365           ([| :stream |
 366              args do: [| *each | stream nextPut: (n applyTo: each)]
 367                   inGroupsOf: n arity] writingAs: #{})]]
 368 ].
 369
 370 #**`er asMethod: #compose: on: {Method traits. Method traits}.
 371 "A named alias for **."
 372
 373 i@(Root traits) converge: block
 374 "Apply block to i until it returns the previously returned value or
 375 the original value. In other words, until no change happens anymore or
 376 we're back at the beginning.
 377 NOTE: The originality test is used to avoid endless loop. It's
 378 possible to construct blocks that don't always return the same
 379 value for same input, so should there be another converge without this
 380 test?"
 381 [| current last |
 382   current := block applyWith: i.
 383   [{i. last} includes: current] whileFalse:
 384     [last := current.
 385      current := block applyWith: current].
 386   current
 387 ].
 388
 389 "Adverb operators:" (
 390
 391 m@(Method traits) reducer
 392 "Over in K"
 393 [#(reduce: m) `er].
 394
 395 m@(Method traits) collecter
 396 "Each in K"
 397 [#(collect: m) `er].
 398
 399 m@(Method traits) acrosser
 400 "Rename me"
 401 [#(m across: _) `er].
 402
 403 m@(Method traits) tracer
 404 "Scan or trace in K."
 405 [#(trace: m) `er].
 406
 407 m@(Method traits) selecter
 408 [#(select: m) `er].
 409
 410 m@(Method traits) injecter
 411 "Over dyad in K"
 412 [[| :arg1 :arg2 | arg2 inject: arg1 into: m]].
 413
 414 m@(Method traits) converger
 415 [#(converge: m) `er].
 416
 417 m@(Method traits) applier
 418 [#(m applyTo: _) `er].
 419
 420 ).
 421
 422 m@(Method traits) fill: arg with: val
 423 "Answer a new method based on the given one, with the argument at a given index
 424 filled in with a value, essentially currying the method."
 425 [
 426   (arg between: 0 and:
 427     (m acceptsAdditionalArguments ifTrue: [PositiveInfinity] ifFalse: [m arity - 1]))
 428     ifFalse: [error: 'Attempted to fill nonexistent method argument.'].
 429   [| *args | m applyTo: (args copyWith: val at: arg)]
 430 ].
 431
 432 m@(Method traits) <-* val
 433 [
 434   [| *args | m applyTo: (args copyWith: val)]
 435 ].
 436
 437 Method traits Identity ::= [| :x | x].
 438 "The method Identity does nothing but return its sole argument."
 439
 440 Method traits Y ::=
 441   [| :f | [| :x | f applyWith: (x applyWith: x)]
 442      applyWith: [| :x | f applyWith: (x applyWith: x)]].
 443 "The Y recursion combinator - also known as the fixed-point combinator, since
 444 it computes the fixed point of any single-argument Method it is applied with.
 445 The core property is that (f applyWith: (Y applyWith: f)) = (Y applyWith: f)
 446 for any method f. The practical use is allowing the definition of anonymous
 447 recursive Methods from Methods which define the individual step (and take an
 448 extra argument which is the Method to recurse on when appropriate)."
 449
 450 Method traits define: #SequentialComposition &parents: {Method} &slots: {#methods -> #{}}.
 451
 452 "A Method's SequentialComposition takes several methods with compatible
 453 signatures and applies them in order to the same arguments."
 454
 455 mc@(Method SequentialComposition traits) newForAll: c
 456 [mc clone `>> [methods := c as: mc methods. ]].
 457
 458 mc@(Method SequentialComposition traits) applyTo: args
 459 [mc contents do: #applyTo: `er <-* args].
 460
 461 Method traits define: #Converse &parents: {Method} &slots: {#method -> []}.
 462 "A Method's converse takes the arguments in reverse to produce the same
 463 result. This implementation works on any method arity, but the client needs
 464 to be aware of this arity, naturally."
 465
 466 m@(Method traits) converse
 467 "Answers a new converse of the given method."
 468 [m Converse cloneSettingSlots: #{#method} to: {m}].
 469
 470 mc@(Method Converse traits) arity
 471 "The arity is inherited from the inner method."
 472 [mc method arity].
 473
 474 mc@(Method Converse traits) allSelectorsSent
 475 "The selectors sent is inherited from the inner method."
 476 [mc method allSelectorsSent].
 477
 478 mc@(Method Converse traits) converse
 479 "A converse of a converse is the original method."
 480 [mc method].
 481
 482 mc@(Method Converse traits) do
 483 [mc method do].
 484
 485 mc@(Method Converse traits) applyWith: obj
 486 [mc method applyWith: obj].
 487
 488 mc@(Method Converse traits) applyWith: obj1 with: obj2
 489 [mc method applyWith: obj2 with: obj1].
 490
 491 mc@(Method Converse traits) applyWith: obj1 with: obj2 with: obj3
 492 [mc method applyWith: obj3 with: obj2 with: obj1].
 493
 494 mc@(Method Converse traits) applyTo: array
 495 [mc method applyTo: array reversed].
 496
 497 m@(Method traits) swing
 498 "This is a higher-order function which does a reverse distribution of sorts.
 499 It was ported from:
 500 - http://www.haskell.org/hawiki/LicensedPreludeExts
 501 - http://www.haskell.org/haskellwiki/Pointfree#Swing
 502 Example: collect: takes a collection of objects and a method,
 503   #collect:`er swing takes an object and a collection of methods.
 504 TODO: Improve the documentation, and add examples."
 505 [
 506   m arity = 2
 507     ifTrue: [[| :b :a | m apply*, a, [| :g | g apply*, b]]]
 508     ifFalse:
 509       [TODO: 'Implement multi-argument swing.'
 510        "[| *args | m applyTo: {args last} ; args allButLast reversed]"]
 511 ].