diff --git a/goblins/actor-lib/lexical-methods.rkt b/goblins/actor-lib/lexical-methods.rkt new file mode 100644 index 0000000..fbad46b --- /dev/null +++ b/goblins/actor-lib/lexical-methods.rkt @@ -0,0 +1,147 @@ +#lang racket/base + +;;; Copyright 2019-2021 Christine Lemmer-Webber +;;; Copyright 2022 Jessica Tallon +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(require (for-syntax racket/base + syntax/parse + racket/match) + racket/contract + "../core.rkt" + "select-swear.rkt") + +(provide lexical-methods) + +(define raise-method-not-found + (make-keyword-procedure + (lambda (kws kw-args method . args) + (error 'method-not-found "~a" method)))) + +(define/contract (make-extends-handler extend-refr) + (-> live-refr? any/c) + (define $/<- + (select-$/<- extend-refr)) + (define extends-handler + (make-keyword-procedure + (lambda (kws kw-args . args) + (keyword-apply $/<- kws kw-args extend-refr args)))) + extends-handler) + +(define-syntax (lexical-methods stx) + (define-values (methods method-not-found-handler) + (let lp ([stx-to-process (cdr (syntax-e stx))] + [clauses '()] + [not-found-handler #f]) + (match stx-to-process + ['() + (values (reverse clauses) + (or not-found-handler + #'raise-method-not-found))] + [(list clause rest-clauses ...) + (define clause-e + (syntax-e clause)) + (cond + ;; Okay, we're setting up an fallback definition + [(eq? clause-e '#:extends) + (match rest-clauses + [(cons extends-refr rest-clauses) + (lp rest-clauses + clauses + extends-refr)] + ['() + (raise-syntax-error + 'methods-invalid-extends-refr + "#:extends must be followed by an extension mechanism")])] + [else + (define new-clause + (syntax-parse clause + [((method-name method-args ...) body ...) + #'(cons method-name + (lambda (method-args ...) + body ...))] + [((method-name method-args ... . rest) body ...) + #'(cons method-name + (lambda (method-args ... . rest) + body ...))] + [(method-name proc) + #'(cons method-name proc)])) + (lp rest-clauses + (cons new-clause clauses) + not-found-handler)])]))) + + #`(procedure-rename + (make-keyword-procedure + (let ([real-not-found-handler + ;; If it's a refr, we need to wrap it in something that will + ;; call the refr + (cond + [(live-refr? #,method-not-found-handler) + (make-extends-handler #,method-not-found-handler)] + [(not #,method-not-found-handler) + raise-method-not-found] + [else + #,method-not-found-handler])]) + (lambda (kws kw-args method-name . args) + (define method + (assoc method-name (list #,@methods))) + (if method + (keyword-apply (cdr method) kws kw-args args) + (keyword-apply real-not-found-handler + kws kw-args method-name args))))) + 'methods)) + +(module+ test + (require rackunit) + + ;; Normally lexical methods are provided by cadifying a description. + (define foo 'foo-abc123) + (define bar 'bar-def456) + (define baz 'baz-ghi789) + + (define some-methods + (lexical-methods + [(foo x) + (list 'foo x)] + [bar + (lambda (x) + (list 'bar x))] + [(baz . args) + (list 'baz args)])) + (check-equal? + (some-methods foo 'beep) + '(foo beep)) + (check-equal? + (some-methods bar 'beep) + '(bar beep)) + (check-equal? + (some-methods baz 'beep 'boop 'bop) + '(baz (beep boop bop))) + + (define some-methods-with-custom-fallback + (lexical-methods + #:extends + (make-keyword-procedure + (lambda _ 'haha-fallback)) + [(foo x) + (list 'foo x)] + [bar + (lambda (x) + (list 'bar x))] + [(baz . args) + (list 'baz args)])) + + (check-equal? + (some-methods-with-custom-fallback 'blorp) + 'haha-fallback))