#lang scheme/base
(provide
state-lambda update
state-update
stack
stack-list
stack-cons
stack-uncons
stack-top
stack-lambda
make-state:stack
state:stack
scat-dwim
scat-wrap-dynamic
)
(require
"../rpn.ss"
scheme/match
scheme/stxparam
(for-syntax
"../ns-tx.ss"
scheme/pretty
scheme/base))
(define-struct state (update))
(define-syntax-parameter update
(lambda (stx)
(raise-syntax-error #f "can only be used inside `state-lambda'" stx)))
(define-syntax (state-lambda stx)
(syntax-case stx ()
((_ state-type (var ...) . expr)
#`(lambda (state)
(match state
((struct state-type (update-fn var ...))
(let ((_update
(lambda args
(apply update-fn state args))))
(syntax-parameterize
((update (make-rename-transformer #'_update)))
. expr)))
(else
(error 'state-lambda "match failed for ~s, wanted type ~s"
state 'state-type)))))))
(define-struct (stack state) (list))
(define (make-state:stack l)
(let ((update (lambda (state lst) (make-state:stack lst))))
(make-stack update l)))
(define (state:stack)
(make-state:stack '()))
(define (stack-cons a s)
((state-lambda stack (l)
(update (cons a l)))
s))
(define stack-uncons
(state-lambda stack
(stack)
(unless (pair? stack)
(error 'stack-underflow))
(values
(car stack)
(update (cdr stack)))))
(define-syntax stack-lambda
(syntax-rules ()
((_ formals . body)
(state-lambda stack
(stack)
(update
(apply (lambda formals . body) stack))))))
(define (stack-top s)
(let-values
(((top rest) (stack-uncons s)))
top))
(define (scat-wrap-dynamic fn)
(unless (procedure? fn)
(error 'scat-wrap-dynamic "not a procedure: ~a\n" fn))
(state-lambda stack
(stack)
(update
(apply (rpn-wrap-dynamic fn) stack))))
(define-syntax (scat-dwim stx)
(syntax-case stx ()
((_ id)
(let ((pid (ns-prefixed #'(scat) #'id)))
(if (identifier-binding pid)
pid
#'(scat-wrap-dynamic id))))))