球拍中的 c(a|d)+r 宏答案

【问题标题】：c(a|d)+r macro in Racket球拍中的 c(a|d)+r 宏
【发布时间】：2012-02-27 11:10:31
【问题描述】：

我想知道是否可以在 Racket 中编写一个宏来翻译各种形式的形状 (c(a|d)+r xs)，其中 c(a|d)+r 是匹配汽车的正则表达式，cdr , caar, cadr, ... 等，变成 first 和 rest 的对应组成。

例如，此宏应采用 (caadr '(1 2 3 4 5)) 并将其转换为 (first (first (rest '(1 2 3 4 5))))。

Shen（Mark Tarver 的新编程语言）中的类似内容：https://groups.google.com/group/qilang/browse_thread/thread/131eda1cf60d9094?hl=en

【问题讨论】：

标签： macros lisp racket cons

【解决方案1】：

您当然可以编写一些内容，接收带引号的 s 表达式并将翻译输出为带引号的 s 表达式。

首先将格式良好的列表（如 '(#\c #\a #\d #\r)）转换为您的第一个/其余 s 表达式。

现在用 symbol?、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)))

正如 cmets 中所述，我很好奇您为什么需要宏。如果目的是将源代码转换为可读的东西，您不想捕获输出以替换原始内容吗？

【讨论】：

OP 要求一个宏；如果它只是一个接受 S 表达式并返回它的函数，则仍然需要 eval 才能运行。 :-)
如果目的是翻译源代码使其可读，那么您不需要宏。我认为 OP 想要将代码转换为代码，而不是评估它（尽管要求宏）。
是的，这是一个合理的期望，但请参阅我的帖子上的 OP 的 cmets。
@ChrisJester-Young：唉，你是对的。嗯，今天早上花一些时间是一个有趣的难题（这是我以前真正想做的事情）。
@chris 好的，我已经尝试让您的宏按照 OP 在github.com/dyoo/fallthrough-racket 中请求的方式工作。因此，您可以很容易地使 Racket 以这种方式运行。但它突然使理解这种“失败”语言的代码变得更难，也更难知道发生了什么。 fallthrough 宏最终会遍及一切，这使得 register-fallthrough 宏对程序员不友好。它很可爱，但我永远不会在生产代码中使用它：它对人类太敌对了。

【解决方案2】：

这是我的实现（现在已修复为使用呼叫站点的 car 和 cdr，因此您可以重新定义它们，它们将正常工作）：

(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

【讨论】：

谢谢 Chris，但是在操作员位置没有咬人的情况下你能做到吗？
那么，您问的是，当无法识别的东西处于应用程序位置时激活某个宏，对吗？一种方法是在 Racket 中覆盖 #%app。但是，应用于一种语言是一个如此普遍的变化！有关出于可疑目的覆盖 #%app 的示例，请参阅 github.com/dyoo/infix-syntax-example。类似地挂钩 Chris Jester-Young 的解决方案应该很简单。
@RacketNoob 是的，它确实有效，如果你更新宏（确保它是带有datum->syntax 的版本），并记得写在biteme 中（我忘记了后者很糟糕)。 :-)
@chris：在你的上一个示例中，我仍然收到“expand: unbound identifier in module in: cdaaaaar”错误，
@RacketNoob：见github.com/dyoo/fallthrough-racket/blob/master/…。

【解决方案3】：

Let Over Lambda 是一本使用 Common Lisp 的书，但它有一个 chapter，其中定义了一个宏 with-all-cxrs，可以满足您的要求。

【讨论】：

唉，CL 宏与 Scheme 宏有很大不同！
@Daimrod：Let Over Lambda 中描述的解决方案不像 Shen 中的解决方案那样优雅，在此链接中描述（因为它要求我们在想要使用任何一个时都使用 with-all-cxrs 形式cxr 函数）：groups.google.com/group/qilang/browse_thread/thread/…
@RacketNoob：哇，我听说过沉，但我从没想过它这么棒。这种宏看起来真的很神奇，我需要更多地了解沉，谢谢你的链接。 :) 但是正如您提供的链接中所说，我认为这在 Scheme 或 CL 中是不可能的。或者也许在带有阅读器宏的 CL 中......但这不像 Shen 那样干净。

【解决方案4】：

在 Racket 中完全可以做到这一点，而且比上面做的要短得多。涉及两个（不是真的）技巧：

使用 Racket 的 #%top 宏可以凭空创建此类绑定。这个宏被隐式地用于任何未绑定的变量引用（“top”，因为这些东西是对顶级变量的引用）。
如果你让宏做必要的最低限度的工作，宏就会变得更简单，剩下的交给函数。

这是包含 cmets 和测试的完整代码（实际代码很小，大约 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

【讨论】：

太棒了！这个解决方案正是我想要的，谢谢！ Racket 是一种真正美丽而强大的语言。
@RacketNoob 大多数 Racket 开发人员都推荐如何设计程序。这不是 Racket 手册，它可能不包括 #%top，但它仍然是一本有用的书。
@chris 是的，它很有用。但是，不幸的是，HtDP 是唯一一本关于 Racket 的书，而且仅供初学者使用。