c (a | d) + r макрос в ракетке

Question

Интересно, можно ли написать макрос в Racket, который бы переводил каждую форму фигуры (c (a | d) + r xs), где c (a | d) + r - это регулярное выражение, соответствующее машине, cdr , caar, cadr, ... и т. д., в соответствующий состав первого и остальных.

Например, этот макрос должен взять (caadr '(1 2 3 4 5)) и преобразовать его в (first (first (rest' (1 2 3 4 5)))).

Примерно так в Shen (новый язык программирования Марка Тарвера): https://groups.google.com/group/qilang/browse_thread/thread/131eda1cf60d9094?hl=en

Answer 1

Очень возможно сделать именно это в Racket, и гораздо более коротким способом, чем сделано выше. Есть два (не очень) трюка:

1. Использование макроса Racket #%top позволяет создавать такие привязки из воздуха. Этот макрос используется неявно вокруг любой ссылки на переменную, которая не связана («top», потому что эти вещи являются ссылками на переменные верхнего уровня).

2. Макросы значительно упрощаются, если вы заставляете их выполнять необходимый минимум, а остальные оставляете функции.

Вот полный код с комментариями и тестами (фактический код крошечный, ~ 10 строк).

#lang racket

;; we're going to define our own #%top, so make the real one available
(require (only-in racket [#%top real-top]))
;; in case you want to use this thing as a library for other code
(provide #%top)

;; non-trick#1: doing the real work in a function is almost trivial
(define (c...r path)
  (apply compose (map (λ(x) (case x [(#\a) car] [(#\d) cdr])) path)))

;; non-trick#2: define our own #%top, which expands to the above in
;; case of a `c[ad]*r', or to the real `#%top' otherwise.
(define-syntax (#%top stx)
  (syntax-case stx ()
    [(_ . id)
     (let ([m (regexp-match #rx"^c([ad]*)r$"
                            (symbol->string (syntax-e #'id)))])
       (if m
         #`(c...r '#,(string->list (cadr m)))
         #'(real-top . id)))]))

;; Tests, to see that it works:
(caadadr '(1 (2 (3 4)) 5 6))
(let ([f caadadr]) (f '(1 (2 (3 4)) 5 6))) ; works even as a value
(cr 'bleh)
(cadr '(1 2 3))    ; uses the actual `cadr' since it's bound,
;; (cadr '(1))     ; to see this, note this error message
;; (caddddr '(1))  ; versus the error in this case
(let ([cr list]) (cr 'bleh)) ; lexical scope is still respected

Answer 2

Вы, конечно, можете написать что-то, что принимает в s-выражение в кавычках и выводит перевод как s-выражение в кавычках.

Начните с простого перевода правильно сформированных списков, таких как '(#\c #\a #\d #\r), в ваши первые / остальные s-выражения.

Теперь создайте решение с помощью символа ?, symbol-> string, regexp-match #rx "^ c (a | d) + r $", string-> list и map

Пройдите через вход. Если это символ, проверьте регулярное выражение (верните как есть, если это не удалось), преобразуйте в список и используйте ваш начальный переводчик. Рекурс по вложенным выражениям.

РЕДАКТИРОВАТЬ: вот некоторый плохо написанный код, который может переводить источник в источник (при условии, что целью является чтение выходных данных)

;; translates a list of characters '(#\c #\a #\d #\r)
;; into first and rest equivalents
;; throw first of rst into call
(define (translate-list lst rst)
  (cond [(null? lst) (raise #f)]
        [(eq? #\c (first lst)) (translate-list (rest lst) rst)]
        [(eq? #\r (first lst)) (first rst)]
        [(eq? #\a (first lst)) (cons 'first (cons (translate-list (rest lst) rst) '()))]
        [(eq? #\d (first lst)) (cons 'rest (cons (translate-list (rest lst) rst) '()))]
        [else (raise #f)]))

;; translate the symbol to first/rest if it matches c(a|d)+r
;; pass through otherwise
(define (maybe-translate sym rst)
  (if (regexp-match #rx"^c(a|d)+r$" (symbol->string sym))
      (translate-list (string->list (symbol->string sym)) rst)
      (cons sym rst)))

;; recursively first-restify a quoted s-expression
(define (translate-expression exp)
  (cond [(null? exp) null]
        [(symbol? (first exp)) (maybe-translate (first exp) (translate-expression (rest exp)))]
        [(pair? (first exp)) (cons (translate-expression (first exp)) (translate-expression (rest exp)))]
        [else exp]))

'test-2
(define test-2 '(cadr (1 2 3)))
(maybe-translate (first test-2) (rest test-2))
(translate-expression test-2)
(translate-expression '(car (cdar (list (list 1 2) 3))))
(translate-expression '(translate-list '() '(a b c)))
(translate-expression '(() (1 2)))

Как уже упоминалось в комментариях, мне любопытно, зачем вам нужен макрос. Если цель состоит в том, чтобы перевести источник в нечто читаемое, не хотите ли вы захватить вывод для замены оригинала?

Answer 3

Let Over Lambda - это книга, в которой используется Common Lisp, но в ней есть глава , в которой он определяет макрос with-all-cxrs, который делает то, что вы хотите.

Answer 4

Вот моя реализация (теперь исправлено использование car и cdr для call-сайта, поэтому вы можете переопределить их, и они будут работать правильно):

(define-syntax (biteme stx)
  (define (id->string id)
    (symbol->string (syntax->datum id)))
  (define (decomp id)
    (define match (regexp-match #rx"^c([ad])(.*)r$" (id->string id)))
    (define func (case (string-ref (cadr match) 0)
                  ((#\a) 'car)
                  ((#\d) 'cdr)))
    (datum->syntax id (list func (string->symbol (format "c~ar" (caddr match))))))
  (syntax-case stx ()
    ((_ (c*r x)) (regexp-match #rx"^c[ad]+r$" (id->string #'c*r))
     (with-syntax (((a d) (decomp #'c*r)))
       (syntax-case #'d (cr)
         (cr #'(a x))
         (_ #'(a (biteme (d x)))))))))

Примеры:

(biteme (car '(1 2 3 4 5 6 7)))        ; => 1
(biteme (cadr '(1 2 3 4 5 6 7)))       ; => 2
(biteme (cddddr '(1 2 3 4 5 6 7)))     ; => (5 6 7)
(biteme (caddddddr '(1 2 3 4 5 6 7)))  ; => 7
(let ((car cdr)
      (cdr car))
  (biteme (cdaaaaar '(1 2 3 4 5 6 7)))) ; => 6