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

#; ;Doesn't work!
(define-for-syntax (check-identifier? loc obj)
  (unless (symbol? (strip-syntax obj))
    (syntax-error "bad argument type - not an identifier" obj)) )

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