;;;; reflect-reify.scm ;;;; Kon Lovett, Oct 10 '06 ;; Monads from shift and reset (from Filinski, POPL '94) (module reflect-reify (;export define-bind define-unit reflect reify) (import scheme (chicken base) (chicken syntax) shift-reset) (import-for-syntax (chicken string)) (define-for-syntax (suffix-identifier id sym) (string->symbol (conc (strip-syntax id) #\- (strip-syntax sym))) ) (define-for-syntax (bind-identifier id) (suffix-identifier id 'bind)) (define-for-syntax (unit-identifier id) (suffix-identifier id 'unit)) (define-syntax define-bind (er-macro-transformer (lambda (frm rnm cmp) (##sys#check-syntax 'define-bind frm '(_ symbol _ . _)) (let ((_define (rnm 'define))) (let ((kind (cadr frm)) (body (cddr frm)) ) `(,_define (,(bind-identifier kind) monad func) ,@body) ) ) ) ) ) (define-syntax define-unit (er-macro-transformer (lambda (frm rnm cmp) (##sys#check-syntax 'define-unit frm '(_ symbol _ . _)) (let ((_define (rnm 'define))) (let ((kind (cadr frm)) (body (cddr frm)) ) `(,_define (,(unit-identifier kind) obj) ,@body) ) ) ) ) ) (define-syntax reflect (er-macro-transformer (lambda (frm rnm cmp) (##sys#check-syntax 'reflect frm '(_ symbol _)) (let ((_shift (rnm 'shift))) (let ((kind (cadr frm)) (meaning (caddr frm)) ) `(,_shift k (,(bind-identifier kind) ,meaning k)) ) ) ) ) ) (define-syntax reify (er-macro-transformer (lambda (frm rnm cmp) (##sys#check-syntax 'reify frm '(_ symbol _)) (let ((_reset (rnm 'reset))) (let ((kind (cadr frm)) (expr (caddr frm)) ) `(,_reset (,(unit-identifier kind) ,expr)) ) ) ) ) ) ) ;module reflect-reify