Haskellっぽいカリー化関数の構文

Scheme

以前作ったMLっぽいカリー化関数の構文を使って、今度はHaskellっぽいのを作ってみました。

こういうことが出来るようになります。

関数定義:

> (add x y := (+ x y))
> (add 1 2)
3
> ((add 1) 2)
3

ラムダ式:

> (map (x -> (+ x 1))
       '(1 2 3))
(2 3 4)
> (map (x y -> (+ x y))
       '(1 2 3) '(4 5 6))
(5 7 9)

セクション、と言うか Arc の角括弧:

> (map [+ _ 1] '(1 2 3))
(2 3 4)
> (map (+ _ 1) '(1 2 3))
(2 3 4)


以下、実装です。関数適用のフォームの評価をインターセプトし、新たな構文規則を追加するという、かなり過激なハックとなっています。

(provide (rename-out (my-app #%app)))

(define-syntax (my-app stx)
  (syntax-case stx ()
    ((my-app n . e)
     (stx-any declare? #'e)
     (receive (v e) (stx-break declare? #'e)
       (quasisyntax/loc stx
         (fun (n #,@v) #,@e))))
    ((my-app . e)
     (stx-any lambda? #'e)
     (receive (v e) (stx-break lambda? #'e)
       (quasisyntax/loc stx
         (fn #,v #,@e))))
    ((my-app . e)
     (stx-any hole? #'e)
     (quasisyntax/loc stx
       (cute
        #,@(map (lambda (stx)
                  (if (hole? stx) (syntax/loc stx <>) stx))
                (syntax->list #'e)))))
    ((my-app . e)
     (syntax/loc stx (#%app . e)))))

ユーティリティ:

(begin-for-syntax
  (fun (same-id? id stx) (eq? id (syntax-e stx)))

  (define-values (declare? lambda? hole?)
    (values (same-id? ':=) (same-id? '->) (same-id? '_)))

  (define (stx-any p? stx)
    (ormap p? (syntax->list stx)))

  (define (stx-break p? stx)
    (receive (l r) (break p? (syntax->list stx))
      (values l (cdr r)))))

構文展開系によって関数適用と見なされた式を捕らえ、特殊な識別子を含むかどうかチェックしています。

:= を含んでいれば関数定義、-> があればラムダ式、という風に分岐して振る舞いを変えるわけです。

Haskell みたく = を関数定義のために使いたかったんですが、そうすると関数としての = を引数として渡すことが不可能になるため、:= にしました。


追記:

Haskellの [i .. j] の構文を加えてみました。

数値

> (1 .. 10)
(1 2 3 4 5 6 7 8 9 10)
> (1 3 .. 10)
(1 3 5 7 9)

文字

> (#\a .. #\c)
(#\a #\b #\c)
> (#\a #\c .. #\z)
(#\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u #\w #\y)

関数構文と

> (map [+ _ 1] (1 3 .. 10))
(2 4 6 8 10)


実装

(define (stop? start stop)
  (let ((cmp (if (> stop start) > <)))
    (lambda (x) (cmp x stop))))

(define (succ start next stop)
  (cond (next
	 (let ((step (- next start)))
	   (lambda (x) (+ x step))))
	((> stop start) add1)
	(else sub1)))

(define (unfold-args value number start next stop)
  (receive (start next stop)
      (values (number start) (and next (number next)) (number stop))
    (values (stop? start stop) value (succ start next stop) start)))

(define (accum start next stop)
  (call-with-values
      (lambda ()
	(cond ((number? start)
	       (unfold-args values values start next stop))
	      ((char? start)
	       (unfold-args integer->char char->integer start next stop))))
    unfold))

(define-syntax (app-range stx)
  (define (stx-every p? l)
    (andmap p? (map syntax-e l)))

  (define (literal? . l)
    (or (stx-every number? l)
        (stx-every char? l)))

  (syntax-case* stx (..)
      (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
    ((app-range i .. j)
     (literal? #'i #'j)
     (quasisyntax/loc stx
       '#,(accum (syntax-e #'i) #f (syntax-e #'j))))
    ((app-range i .. j)
     (syntax/loc stx (accum i #f j)))
    ((app-range i j .. k)
     (literal? #'i #'j #'k)
     (quasisyntax/loc stx
       '#,(accum (syntax-e #'i) (syntax-e #'j) (syntax-e #'k))))
    ((app-range i j .. k)
     (syntax/loc stx (accum i j k)))
    ((app-range . e)
     (syntax/loc stx (app-fun . e)))))

リテラルが与えられた場合、コンパイル時にリスト生成が行われるのがポイントです:

> (syntax->datum (expand '(1 3 .. 10)))
(quote (1 3 5 7 9))

iota とかを使うよりも効率が良いわけです。

変数を含んでいる場合はこのようになります:

> (syntax->datum
   (expand
    '(let ((next 3)) (1 next .. 10))))
(let-values (((next) (quote 3))) (#%app accum (quote 1) next (quote 10)))

なお、リスト生成には iota ではなく、同じく SRFI-1 の unfold という関数を使っています。あまりポピュラーな関数ではないと思うんですが、なかなか奥が深そうです。


ファイル:
mlfun.ss
hasfun.ss
hasfun-helper.ss


参考文献:
Fun with paran-shape