Clojure のスレッディングマクロを Scheme で。

入門が https://t.laafc.net/tags/syntax-rules-primer.html 終わったので、実際に何か書いてみることにします。ここで Clojure のスレッディングマクロを題材にします。

Clojure のスレッディングマクロ

手始めに thread-first と thread-last から。

(define-syntax thread-first
  (syntax-rules ()
    ((_ e) e)
    ((_ e (x . xs) . more)
     (thread-first (x e . xs) . more))
    ((_ e x . more)
     (thread-first (x e) . more))))

(thread-first a b c d)
;;-> (d (c (b a)))
(thread-first a (b argb) (c argc) (d argd argd1))
;;-> (d (c (b a argb) argc) argd argd1)

(define-syntax thread-last
  (syntax-rules ()
    ((_ e) e)
    ((_ e (xs ...) . more)
     (thread-last (xs ... e) . more))
    ((_ e x . more)
     (thread-last (x e) . more))))

(thread-last a b c d)
;;-> (d (c (b a)))
(thread-last a (b argb) (c argc) (d argd argd1))
;;-> (d argd argd1 (c argc (b argb a)))

これには問題があって (-> a ()) の挙動が一定しないので修正します。 thread-last の方を修正。 syntax-error を呼ぶのが良いような気がするけれども…

(thread-first a ())
;;-> (() a)  ;; こちらが Clojure の挙動のようです。
;; ここで `()` に対しては  syntax-error を呼ぶのも考えられます。
(thread-last a ())
;;-> (a)

(define-syntax thread-last
  (syntax-rules ()
    ((_ e) e)
    ((_ e (x xs ...) . more)
     (thread-last (x xs ... e) . more))
    ((_ e x . more)
     (thread-last (x e) . more))))

(thread-last a ())
;;-> (() a)
(thread-last a b c d)
;;-> (d (c (b a)))
(thread-last a (b argb) (c argc) (d argd argd1))
;;-> (d argd argd1 (c argc (b argb a)))

... をパターンに使っている所で、最低一つは要素があるようにパターンを変更しました。

さて、ここからアレンジを加えます。任意の位置にフォームをねじ込むものを考えます。ここで、位置の指定が無かった場合には thread-first と同じ挙動となる thread-first-% を考えます。まず、 % を一つだけ考慮する、という手抜き実装をしてみて様子を見ます。

(define-syntax thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (thread-first-%-aux e0 e1 () . more))))

;; 段々整理して行って形にした後にこのコメントの文章を書いているのだけれども、このコードを書いた当時は色々と考えるのがわずらわしくて、相互再帰すれば多分都合良く行くだろう、と軽く考えていました。

(define-syntax thread-first-%-aux
  (syntax-rules (%)
    ((_ e () (x . xs) . more)
     (thread-first-% (x e . xs) . more))
    ((_ e (% . xs) (acc ...) . more)
     (thread-first-% (acc ... e . xs) . more))
    ((_ e (x . xs) (acc ...) . more)
     (thread-first-%-aux e xs (acc ... x) . more))
    ((_ e x _ . more)
     (thread-first-% (x e) . more))))

(thread-first-% a b c d)
;;-> (d (c (b a)))
(thread-first-% a (b argb) (c argc) (d argd argd1))
;;-> (d (c (b a argb) argc) argd argd1)
(thread-first-% a (b % argb) (c argc %) (d argd % argd1))
;;-> (d argd (c argc (b a argb)) argd1)
(thread-first-% (values 1 2) (receive (x y) % (list x y)))
;;-> (receive (x y) (values 1 2) (list x y))

見通しが悪いので、 thread-first-%-aux から thread-first-% を呼び出している部分を、呼び出し元に移動します。 thread-first-%-aux では e0 と e1 を展開することのみに変更してみます。

(define-syntax thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (thread-first-% (thread-first-%-aux e0 e1 ()) . more))))

(define-syntax thread-first-%-aux
  (syntax-rules (%)
    ((_ e () (x . xs)) (x e . xs))
    ((_ e () xs) xs)
    ((_ e (% . xs) (acc ...)) (acc ... e . xs))
    ((_ e (x . xs) (acc ...))
     (thread-first-%-aux e xs (acc ... x)))
    ((_ e x _xs) (x e))))

次に % を複数処理できるようにします。補助マクロへ引数を追加、リテラル % を見たかどうかのフラグを追加します。複数指定することが必要かどうかは脇へ置いておきます…

(define-syntax thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (thread-first-% (thread-first-%-aux e0 e1 () (#f)) . more))))

(define-syntax thread-first-%-aux
  (syntax-rules (%)
    ((_ e () (x . xs) (#f)) (x e . xs))
    ((_ e () xs (%)) xs)
    ((_ e (% . xs) (acc ...) _l)
     (thread-first-%-aux e xs (acc ... e) (%)))
    ((_ e (x . xs) (acc ...) l)
     (thread-first-%-aux e xs (acc ... x) l))
    ((_ e x _xs _l) (x e))))

(thread-first-% a b c d)
;;-> (d (c (b a)))
(thread-first-% a (b argb) (c argc) (d argd argd1))
;;-> (d (c (b a argb) argc) argd argd1)
(thread-first-% a (b % argb) (c argc %) (d argd % argd1))
;;-> (d argd (c argc (b a argb)) argd1)
(thread-first-% (values 1 2) (receive (x y) % (list x y)))
;;-> (receive (x y) (values 1 2) (list x y))
(thread-first-% 1 print (list % %))
;;-> (list (print 1) (print 1))
(thread-first-% 1 (rlet1 r % (print r)) (list %))
;;-> (list (let ((r 1)) (print r) r))

更にアレンジを加えることを考えてみます。上のやつは式をそのまま次の式へねじ込んでいますが、一旦評価した値を束縛して渡していくようにします。

(define-syntax thread-first-%-1
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (thread-first-%-1 (thread-first-%-aux e0 e1 () (#f)) . more))))

(define-syntax thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (let1 ret e0
       (thread-first-% (thread-first-%-aux ret e1 () (#f)) . more)))))

(thread-first-%-1 1 print (list % %))
;;-> (list (print 1) (print 1))
(thread-first-% 1 print (list % %))
;;->
(let1 ret 1
  (let1 ret (print ret)
    (list ret ret)))

引数を評価しないバージョンを thread-first-%-1 としました。

さて気分を変えて、次は some-> を考えます。 (some-> は引数を評価して束縛して渡して行くことが期待されると考えます。また some-thread-first-% を考えるとして、これとの対比で、引数を評価しないバージョンは thread-first-%-1 としました。)

(define-syntax some-thread-first
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (and-let1 ret e0
       (some-thread-first (some-thread-first-aux ret e1) . more)))))

(define-syntax some-thread-first-aux
  (syntax-rules ()
    ((_ e (x . xs)) (x e . xs))
    ((_ e x) (x e))))

(some-thread-first a b c d)
;;->
(and-let1 ret a
  (and-let1 ret (b ret)
    (and-let1 ret (c ret)
      (d ret))))

(some-thread-first a (b argb) (c argc) (d argd argd1))
;;->
(and-let1 ret a
  (and-let1 ret (b ret argb)
    (and-let1 ret (c ret argc)
      (d ret argd argd1))))

(define-syntax some-thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (and-let1 ret e0
       (some-thread-first-% (thread-first-%-aux ret e1 () (#f)) . more)))))

(some-thread-first-% a b c d)
;;->
(and-let1 ret a
  (and-let1 ret (b ret)
    (and-let1 ret (c ret)
      (d ret))))

(some-thread-first-% a (b % argb) (c argc %) (d argd % argd1))
;;->
(and-let1 ret a
  (and-let1 ret (b ret argb)
    (and-let1 ret (c argc ret)
      (d argd ret argd1))))

次は as-> です。

(define-syntax as-thread
  (syntax-rules ()
    ((_ val _var) val)
    ((_ val var x . xs)
     (let1 var val
       (as-thread x var . xs)))))

(as-thread a v (b v) (c v) (d v))
;;->
(let1 v a
  (let1 v (b v)
    (let1 v (c v)
      (d v))))

;; -> 等の間に狭み込んで使うことを考えられているんだろうか。

(some-thread-first-% #t
                     (as-thread v (begin0 v
                                    (display v)
                                    (newline)))
                     x->string)
;;>> #t
;;=> "#t"

最後は cond-> です。括孤が多いけれども。

(define-syntax cond-thread-first
  (syntax-rules ()
    ((_ e) e)
    ((_ e (test form) . more)
     (let1 var e
       (if test
         (cond-thread-first (thread-first-% var form) . more)
         (cond-thread-first var . more))))))

(let ()
  (use srfi-1 :only (xcons))
  (define (describe-number n)
    (define blob (pa$ cons n))
    (cond-thread-first '()
                        (#t blob)
                        ((odd? n) (cons 'odd %))
                        ((even? n) (cons 'even %))
                        ((positive? n) (xcons 'positive))
                        ((negative? n) (xcons 'negative))))
  (list
   (describe-number 3)
   (describe-number 4)))
;;=> ((positive odd 3) (positive even 4))

全体像がこちらです。

(define-module t.clojure.threading-macros
  (export
   %
   thread-first
   ;;thread-first-aux
   thread-last
   ;;thread-last-aux
   thread-first-%-1
   thread-first-%
   ;;thread-first-%-aux
   thread-last-%-1
   thread-last-%
   ;;thread-last-%-aux
   some-thread-first
   some-thread-last
   some-thread-first-%
   some-thread-last-%
   as-thread
   cond-thread-first
   cond-thread-first-%
   cond-thread-last
   cond-thread-last-%
   ))
(select-module t.clojure.threading-macros)

(define-syntax % (syntax-rules ()))

(define-syntax thread-first
  (syntax-rules ()
    ((_ e) e)
    ((_ e x . more)
     (thread-first (thread-first-aux e x) . more))))

(define-syntax thread-first-aux
  (syntax-rules ()
    ((_ e (x . xs)) (x e . xs))
    ((_ e x) (x e))))

(define-syntax thread-last
  (syntax-rules ()
    ((_ e) e)
    ((_ e x . more)
     (thread-last (thread-last-aux e x) . more))))

(define-syntax thread-last-aux
  (syntax-rules ()
    ((_ e (x xs ...)) (x xs ... e))
    ((_ e x) (x e))))

(define-syntax thread-first-%-1
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (thread-first-%-1 (thread-first-%-aux e0 e1 () (#f)) . more))))

(define-syntax thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (let1 ret e0
       (thread-first-% (thread-first-%-aux ret e1 () (#f)) . more)))))

(define-syntax thread-first-%-aux
  (syntax-rules (%)
    ((_ e () (x . xs) (#f)) (x e . xs))
    ((_ e () xs (%)) xs)
    ((_ e (% . xs) (acc ...) _l)
     (thread-first-%-aux e xs (acc ... e) (%)))
    ((_ e (x . xs) (acc ...) l)
     (thread-first-%-aux e xs (acc ... x) l))
    ((_ e x _xs _l) (x e))))

(define-syntax thread-last-%-1
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (thread-last-%-1 (thread-last-%-aux e0 e1 () (#f)) . more))))

(define-syntax thread-last-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (let1 ret e0
       (thread-last-% (thread-last-%-aux ret e1 () (#f)) . more)))))

(define-syntax thread-last-%-aux
  (syntax-rules (%)
    ((_ e () (x xs ...) (#f)) (x xs ... e))
    ((_ e () xs (%)) xs)
    ((_ e (% . xs) (acc ...) _l)
     (thread-last-%-aux e xs (acc ... e) (%)))
    ((_ e (x . xs) (acc ...) l)
     (thread-last-%-aux e xs (acc ... x) l))
    ((_ e x _xs _l) (x e))))

(define-syntax some-thread-first
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (and-let1 ret e0
       (some-thread-first (thread-first-aux ret e1) . more)))))

(define-syntax some-thread-last
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (and-let1 ret e0
       (some-thread-last (thread-last-aux ret e1) . more)))))

(define-syntax some-thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (and-let1 ret e0
       (some-thread-first-% (thread-first-%-aux ret e1 () (#f)) . more)))))

(define-syntax some-thread-last-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e0 e1 . more)
     (and-let1 ret e0
       (some-thread-last-% (thread-last-%-aux ret e1 () (#f)) . more)))))

(define-syntax as-thread
  (syntax-rules ()
    ((_ val _var) val)
    ((_ val var x . xs)
     (let1 var val
       (as-thread x var . xs)))))

(define-syntax cond-thread-first
  (syntax-rules ()
    ((_ e) e)
    ((_ e (test form) . more)
     (let1 var e
       (if test
         (cond-thread-first (thread-first var form) . more)
         (cond-thread-first var . more))))))

(define-syntax cond-thread-first-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e (test form) . more)
     (let1 var e
       (if test
         (cond-thread-first-% (thread-first-% var form) . more)
         (cond-thread-first-% var . more))))))

(define-syntax cond-thread-last
  (syntax-rules ()
    ((_ e) e)
    ((_ e (test form) . more)
     (let1 var e
       (if test
         (cond-thread-last (thread-last var form) . more)
         (cond-thread-last var . more))))))

(define-syntax cond-thread-last-%
  (syntax-rules ()
    ((_ e) e)
    ((_ e (test form) . more)
     (let1 var e
       (if test
         (cond-thread-last-% (thread-last-% var form) . more)
         (cond-thread-last-% var . more))))))

% は cut が <> 等を探すのと同様で、木を探索しません。Clojureで "% を探す"という役割からすると直観的ではない挙動なのかもしれません。そんな時には as-thread を使うということで割り切ります、という名の手抜きです。