;;;; gshift-greset.scm
;;;; Kon Lovett, Apr 6 '06

;;;; From Indiana University TR611 by Oleg Kiselyov

(module gshift-greset

(;export
  (greset h-value) (gshift h-compose)
  h-datatype? h-compose h-value
  hr-stop hs-stop
  hr-prop hs-prop)

(import scheme
  (chicken base)
  datatype
  shift-reset)

(define-syntax h-cases
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'h-cases frm '(_ _ (_ _) (_ _)))
      (let ((_cases (rnm 'cases)))
        (let ((expr (cadr frm))
              (h-part (caddr frm))
              (hv-part (cadddr frm)) )
         `(cases h-datatype ,expr
             (h-compose ,(car h-part) ,(cadr h-part))
             (h-value ,(list (car hv-part)) ,(cadr hv-part)) ) ) ) ) ) )

(define-syntax greset
  (syntax-rules ()
    ((_ HR E) (HR (reset (h-value E)))) ) )

(define-syntax gshift
  (syntax-rules ()
    ((_ HS F E)
      (shift f* (h-compose (lambda (x) (HS (f* x))) (lambda (F) E))) ) ) )

(define-datatype h-datatype h-datatype?
  (h-value (v (constantly #t)))
  (h-compose (f procedure?) (x procedure?)) )

(define (hr-stop expr)
  (h-cases expr
    ((f x) (greset hr-stop (x f)) )
    (v v ) ) )

(define hs-stop hr-stop)

(define (hr-prop expr)
  (h-cases expr
    ((f x) (x f) )
    (v v ) ) )

(define (hs-prop expr)
  (h-cases expr
    ((f x)
      (shift g (h-compose (lambda (y) (hs-prop (g (f y)))) x)) )
    (v v ) ) )

) ;module gshift-greset