main.rkt

#lang racket

(require syntax-spec-v3
         (for-syntax syntax/parse racket/list))

(syntax-spec
 (binding-class state-name)
 (binding-class event-var #:reference-compiler mutable-reference-compiler)

 (host-interface/expression
  (machine #:initial initial-state:state-name s:state-spec ...)
  #:binding (scope (import s) ... initial-state)
  #'(compile-machine initial-state s ...))

 (nonterminal/exporting state-spec
   (state name:state-name
     ((~datum on-enter) body:racket-body ...+)
     transitions:transition-spec ...)
   #:binding ((export name) (scope (import body) ...))

   (state name:state-name
     transitions:transition-spec ...)
   #:binding (export name))

 (nonterminal transition-spec
   (on (event-name:id arg:event-var ...)
     body:racket-body
     ...
     ((~datum goto) next-state:state-name))
   #:binding (scope (bind arg) ... (import body) ...))
 )

(define-syntax compile-machine
  (syntax-parser
    #:datum-literals (machine state on-enter)
    ((_ initial-state
        (state state-name
          (~optional (on-enter action ...)
                     #:defaults (((action 1) '())))
          e ...)
        ...)
     #'(let ()
         (define machine%
           (class object%
             (define state #f)
             (define/public (set-state state%)
               (set! state (new state% (machine this))))
             (define/public (get-state)
               (send state get-state))

             (compile-proxy-methods (e ... ...) state)

             (send this set-state initial-state)
             (super-new)))

         (define state-name
           (class object%
             (init-field machine)
             (define/public (get-state)
               'state-name)
             action ...
             (compile-event-method e machine) ...
             (super-new)))

         ...

         (new machine%)))))

(define-syntax compile-proxy-methods
  (syntax-parser
    #:datum-literals (on goto)
    ((_ ((on (event-name . _) . _) ...) target)
     #:with (unique-event ...)
     (remove-duplicates (map syntax-e (attribute event-name)))
     #'(begin
         (define/public (unique-event . args)
           (send/apply target unique-event args))
         ...))))

(define-syntax compile-event-method
  (syntax-parser
    #:datum-literals (on goto)
    ((_ (on (event-name arg ...)
          action ...
          (goto name))
        machine)
     #'(define/public (event-name arg ...)
         action ...
         (send machine set-state name)))))

#;(machine
 #:initial red
 (state red
   (on (event x)
     (goto green))
   (on (event2 x)
     (goto red)))

 (state green)
 )

(define vending-machine
  (machine
   #:initial idle
   (state idle
     (on-enter (displayln "pay a dollar"))
     (on (dollar)
       (goto paid))
     (on (select-item item)
       (displayln "you need to pay before selecting an item")
       (goto idle)))
   (state paid
     (on-enter (displayln "select an item"))
     (on (select-item item)
       (displayln (format "dispensing ~a" item))
       ;(displayln (format "dispensing item"))
       (goto idle)))))

(send vending-machine dollar)
(send vending-machine select-item 'beer)

;; Local Variables:
;; mode: racket
;; eval: (mapcar (lambda (s) (put s 'racket-indent-function 1))
;;         '(nonterminal nonterminal/exporting state on))
;; End: