source: project/release/4/F-operator/trunk/reflect-reify.scm @ 16205

;;;; 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 reflect-values %reflect
  reify reify-values %reify
  ;;
  shift reset)

  (import scheme chicken shift-reset)

  (require-library shift-reset)

(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 reflect-values
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'reflect-values frm '(_ symbol _))
      (let ((_shift-values (rnm 'shift-values)))
        (let ((kind (cadr frm))
              (meaning (caddr frm)) )
          `(,_shift-values k (,(bind-identifier kind) ,meaning k)) ) ) ) ) )

(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)) ) ) ) ) )

(define-syntax reify-values
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'reify-values frm '(_ symbol _))
      (let ((_reset-values (rnm 'reset-values)))
        (let ((kind (cadr frm))
              (expr (caddr frm)) )
          `(,_reset-values (,(unit-identifier kind) ,expr)) ) ) ) ) )

(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