Last active
October 26, 2017 09:19
-
-
Save arucil/8d533834a312bf7f6a03aa696f3aae3b to your computer and use it in GitHub Desktop.
A simple macro-by-example implementation
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;;; Usage: | |
| ;;; (mbe pattern template sexp) | |
| ;;; Expand a single-rule macro (represented by pattern & template) | |
| (define (wrong msg . args) | |
| (apply error 'error msg args)) | |
| (define (match sexp pattern) | |
| (let ([env (match-help (cdr sexp) (cdr pattern))]) | |
| (if env | |
| (map (lambda (lv p) | |
| (cons (car p) | |
| (cons lv (cdr p)))) | |
| (get-levels (cdr pattern) 0) | |
| env)))) | |
| (define (match-help sexp pattern) | |
| (call/cc | |
| (lambda (k) | |
| (define (fail) | |
| (k #f)) | |
| (let rec ([sexp sexp] [pattern pattern]) | |
| (cond | |
| [(symbol? pattern) | |
| (list (cons pattern sexp))] | |
| [(pair? pattern) | |
| (if (has-ellipsis? pattern) | |
| (let loop ([sexp sexp] [env* '()]) | |
| (let ([env (if (pair? sexp) | |
| (match-help (car sexp) (car pattern)) | |
| #f)]) | |
| (if env | |
| (loop (cdr sexp) | |
| (cons (map cdr env) ; removing name part in env | |
| env*)) | |
| (append (apply map | |
| list | |
| (get-pattern-variables (car pattern)) | |
| (reverse env*)) | |
| (rec sexp (cddr pattern)))))) | |
| (if (pair? sexp) | |
| (append (rec (car sexp) (car pattern)) | |
| (rec (cdr sexp) (cdr pattern))) | |
| (fail)))] | |
| [else | |
| (if (eqv? pattern sexp) | |
| '() | |
| (fail))]))))) | |
| (define (has-ellipsis? p) | |
| (and (pair? (cdr p)) | |
| (eq? '... (cadr p)))) | |
| (define (get-pattern-variables p) | |
| (cond | |
| [(pair? p) | |
| (if (has-ellipsis? p) | |
| (append (get-pattern-variables (car p)) | |
| (get-pattern-variables (cddr p))) | |
| (append (get-pattern-variables (car p)) | |
| (get-pattern-variables (cdr p))))] | |
| [(symbol? p) | |
| (list p)] | |
| [else '()])) | |
| (define (get-levels p lv) | |
| (cond | |
| [(pair? p) | |
| (if (has-ellipsis? p) | |
| (append (get-levels (car p) (+ lv 1)) | |
| (get-levels (cddr p) lv)) | |
| (append (get-levels (car p) lv) | |
| (get-levels (cdr p) lv)))] | |
| [(symbol? p) | |
| (list lv)] | |
| [else '()])) | |
| (define (transcribe template env) | |
| (let-values ([(env/lv0 env/lv+) | |
| (split-env env)]) | |
| (transcribe-help template env/lv0 env/lv+))) | |
| ;; return env/lv0 and env/lv+ | |
| (define (split-env env) | |
| (partition (lambda (p) (zero? (cadr p))) env)) | |
| ;; env/lv0 : name -> (0 , sexp) | |
| ;; env/lv+ : name -> (level, sexps) | |
| (define (transcribe-help template env/lv0 env/lv+) | |
| (cond | |
| [(symbol? template) | |
| (cond | |
| [(assq template env/lv0) => cddr] | |
| [(assq template env/lv+) | |
| (wrong "Too few ellipses with" template)] | |
| [else template])] | |
| [(pair? template) | |
| (if (has-ellipsis? template) | |
| (let* ([free-variables (get-pattern-variables (car template))] | |
| [new-env/lv+ (filter (lambda (x) | |
| (memq (car x) free-variables)) | |
| env/lv+)]) | |
| (if (null? new-env/lv+) | |
| (wrong "Too many ellipses") | |
| (let ([names (map car new-env/lv+)] | |
| [levels (map (lambda (x) | |
| (- (cadr x) 1)) | |
| new-env/lv+)] | |
| [sexpss (map cddr new-env/lv+)]) | |
| (if (apply = (map length sexpss)) | |
| (let ([envs (apply map | |
| (lambda sexps | |
| (map (lambda (name level sexp) | |
| (cons name | |
| (cons level sexp))) | |
| names levels sexps)) | |
| sexpss)]) | |
| (append (map (lambda (env) | |
| (let-values ([(new-env/lv0 env/lv+) | |
| (split-env env)]) | |
| (transcribe-help (car template) | |
| (append new-env/lv0 env/lv0) | |
| env/lv+))) | |
| envs) | |
| (transcribe-help (cddr template) env/lv0 env/lv+))) | |
| (wrong "Unequal length"))))) | |
| (cons (transcribe-help (car template) env/lv0 env/lv+) | |
| (transcribe-help (cdr template) env/lv0 env/lv+)))] | |
| [else template])) | |
| (define (mbe pattern template sexp) | |
| (let ([env (match sexp pattern)]) | |
| (if env | |
| (transcribe template env) | |
| #f))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment