add minimal state machine demo

demos/minimal-state-machine/csv-browser.rkt

@@ -0,0 +1,127 @@
+#lang racket/gui
+
+(require "state-machine.rkt"
+         "gui-layout.rkt"
+         net/url
+         csv-reading)
+
+;;
+;; UI elements
+;;
+
+(define frame
+  (new frame%
+       [label "CSV Browser"]
+       [min-width 400]
+       [min-height 200]))
+
+(gui-layout frame 
+  (vertical-pane%
+   (horizontal-pane%
+    [stretchable-height #f]
+
+    (text-field%
+     #:as url-field
+     [label "Data URL"]
+     [init-value "https://people.sc.fsu.edu/~jburkardt/data/csv/addresses.csv"]
+     [callback (lambda _ (send csv-controller url-change))])
+
+    (button%
+     [label "Load"]
+     [callback (lambda _ (send csv-controller load-click))]))
+
+   (pane%
+    #:as data-area
+
+    (message%
+     #:as url-message
+     [label "Enter a URL"])
+
+    (message%
+     #:as loading-message
+     [label "Loading..."])
+
+    (message%
+     #:as error-message
+     [label "Error loading data"])
+
+    (list-box%
+     #:as table
+     [label ""]
+     [columns (list "")]
+     [choices (list)]
+     [style (list 'single 'variable-columns)]))))
+
+;;
+;; UI actions
+;;
+
+(define (set-display to-show)
+  (send data-area change-children (lambda (_) (list to-show))))
+
+(define (set-data data)
+  (for ([i (range (- (length (send table get-column-labels)) 1))])
+    (send table delete-column 1))
+  (for ([i (range (- (length (car data)) 1))])
+    (send table append-column ""))
+  (send table set-column-width 0 100 0 500)
+  (define transposed (apply map list data))
+  (send/apply table set transposed))
+
+
+;;
+;; Data loading
+;;
+
+(define (load-data url)
+  (thread
+   (lambda ()
+     (define (on-error e)
+       (queue-callback
+        (lambda ()
+          (send csv-controller load-error))))
+
+     (with-handlers ([exn:fail? on-error])                                
+       (define data (csv->list (get-pure-port (string->url url))))
+       (queue-callback
+        (lambda ()
+          (send csv-controller loaded data)))))))
+
+;;
+;; Controller via state machine DSL
+;;
+
+(define csv-controller
+  (machine
+   #:initial-state no-data
+   (state no-data
+     (on-enter (set-display url-message))
+     (on (load-click) (-> loading))
+     (on (url-change) (-> no-data)))
+   (state loading
+     (on-enter (set-display loading-message)
+               (load-data (send url-field get-value)))
+     (on (loaded data)
+       (set-data data)
+       (-> display))
+     (on (load-error) (-> error))
+     (on (load-click) (-> loading))
+     (on (url-change) (-> no-data)))
+   (state display
+     (on-enter (set-display table))
+     (on (load-click) (-> loading))
+     (on (url-change) (-> no-data)))
+   (state error
+     (on-enter (set-display error-message))
+     (on (load-click) (-> loading))
+     (on (url-change) (-> no-data)))
+   ))
+
+;;
+;; Run it.
+;;
+
+(send frame show #t)
+
+
+

demos/minimal-state-machine/gui-layout.rkt

@@ -0,0 +1,24 @@
+#lang racket/base
+
+(provide gui-layout)
+
+(require racket/class
+         (for-syntax racket/base syntax/parse racket/syntax syntax/parse/class/paren-shape))
+
+(define-syntax gui-layout
+  (syntax-parser
+    [(_ parent-name:id
+        (class:id (~optional (~seq #:as element-name:id)
+                             #:defaults ([element-name (generate-temporary 'element)]))
+                  [~brackets arg-name:id arg-expr:expr] ...
+                  child ...)
+        ...)
+     #'(begin
+         (define element-name
+           (new class
+                [parent parent-name]
+                [arg-name arg-expr] ...))
+         ...
+         (begin
+           (gui-layout element-name child ...)
+           ...))]))

demos/minimal-state-machine/state-machine-compiler.rkt

@@ -0,0 +1,57 @@
+#lang racket
+
+(provide compile-machine)
+
+(require syntax/parse/define (for-syntax syntax/parse racket/list))
+
+(define-syntax compile-machine
+  (syntax-parser
+    #:datum-literals (machine state on-enter)
+    [(_ initial-state
+        (state state-name
+          (on-enter action ...)
+          e ...)
+        ...)
+     #'(let ()
+         (define machine%
+           (class object%
+             (define state #f)
+             (define/public (set-state state%)
+               (set! state (new state% [machine this])))
+
+             (compile-proxy-methods (e ... ...) state)
+
+             (send this set-state initial-state)
+             (super-new)))
+
+         (define state-name
+           (class object%
+             (init-field machine) 
+             action ...
+             (compile-event-method e machine) ...
+             (super-new)))
+         ...
+
+         (new machine%))]))
+
+(define-syntax compile-proxy-methods
+  (syntax-parser
+    #:datum-literals (on ->)
+    [(_ ((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 ->)
+    [(_ (on (event-name arg ...)
+          action ...
+          (-> name))
+        machine)
+     #'(define/public (event-name arg ...)
+         action ...
+         (send machine set-state name))]))

demos/minimal-state-machine/state-machine.rkt

@@ -0,0 +1,25 @@
+#lang racket
+
+(provide machine state on on-enter)
+
+(require "../../main.rkt" "state-machine-compiler.rkt")
+
+(syntax-spec
+  (binding-class state-name)
+
+  (host-interface/expression
+    (machine #:initial-state s:state-name d:machine-decl ...)
+    #:binding (scope (import d) s)
+    #'(compile-machine s d ...))
+
+  (nonterminal/exporting machine-decl
+    (state n:state-name
+      e:event-decl ...)
+    #:binding (export n))
+
+  (nonterminal event-decl
+    (on-enter e:racket-expr ...)
+    (on (evt:id arg:racket-var ...)
+      e:racket-expr ...
+      ((~datum ->) s:state-name))
+    #:binding (scope (bind arg) e)))