;;;; 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
  ;;
  (reset *reset) (shift *shift))

  (import scheme
          (except chicken reset)
          (only data-structures constantly)
          datatype
          shift-reset)

  (require-library data-structures datatype shift-reset)

(define-syntax h-cases
  (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