0. #lang racket
1. (require racket/control)
2.  
3. (struct Done (x))
4. (struct Eff (op k))
5. (define (perform op) (shift k (Eff op k)))
6.  
7. (define-syntax (handler stx)
8.   (define (handle-cases cases value-cases eff-cases finally-cases)
9.     (syntax-case cases (effect -> finally)
10.       [() (values (reverse value-cases)
11.                   (reverse eff-cases)
12.                   (reverse finally-cases))]
13.       [((p -> e1 e2 ...) . cases)
14.        (handle-cases #'cases
15.                      (cons #'(p e1 e2 ...) value-cases)
16.                      eff-cases
17.                      finally-cases)]
18.       [((effect p k -> e1 e2 ...) . cases)
19.        (handle-cases #'cases
20.                      value-cases
21.                      (cons #'((p k) e1 e2 ...) eff-cases)
22.                      finally-cases)]
23.       [((finally p -> e1 e2 ...) . cases)
24.        (handle-cases #'cases
25.                      value-cases
26.                      eff-cases
27.                      (cons #'(p e1 e2 ...) finally-cases))]))
28.   (syntax-case stx (finally)
29.     [(_ h1 h2 ...)
30.      (let-values ([(value-cases eff-cases finally-cases)
31.                    (handle-cases #'(h1 h2 ...) '() '() '())])
32.        #`(lambda (body)
33.            (define (handle req)
34.              (match req
35.                [(Done x)
36.                 (match x
37.                   #,@value-cases
38.                   [x x])]
39.                [(Eff op k)
40.                 (match* (op (lambda (x) (handle (k x))))
41.                   #,@eff-cases
42.                   [(op _) (handle (k (perform op)))])]))
43.            (match (handle (reset (Done (body))))
44.              #,@finally-cases
45.              [x x])))]))
46.  
47. (define-syntax with-handler
48.   (syntax-rules ()
49.     [(_ handler e1 e2 ...)
50.      (handler (lambda () e1 e2 ...))]))
51.  
52. (define (run-state init)
53.   (handler
54.     [x -> (lambda (s) (cons x s))]
55.     [effect (State:Get) k -> (lambda (s) ((k s) s))]
56.     [effect (State:Set s) k -> (lambda (_) ((k '()) s))]
57.     [finally f -> (f init)]))
58.  
59. (struct State:Get ())
60. (struct State:Set (s))
61. (define (set s) (perform (State:Set s)))
62. (define (get) (perform (State:Get)))
63.  
64. (with-handler (run-state 1)
65.   (set (+ 1 (get)))
66.   (+ (get) (get)))
67. ;; '(4 . 2)
68.  
69. (struct Amb (choices))
70. (define (amb . xs) (perform (Amb xs)))
71. (define run-amb
72.   (handler
73.     [x -> (list x)]
74.     [effect (Amb xs) k -> (append-map k xs)]))
75.  
76. (with-handler run-amb
77.   (with-handler (run-state 1)
78.     (let ([s1 (get)])
79.       (set (+ s1 (amb 1 2 3)))
80.       (cons (amb 1 2 3) (get)))))
81. ;; '(((1 . 2) . 2)
82. ;;   ((2 . 2) . 2)
83. ;;   ((3 . 2) . 2)
84. ;;   ((1 . 3) . 3)
85. ;;   ((2 . 3) . 3)
86. ;;   ((3 . 3) . 3)
87. ;;   ((1 . 4) . 4)
88. ;;   ((2 . 4) . 4)
89. ;;   ((3 . 4) . 4))
90.  
91. ;; or alternative you can define them manually like this
92. ;; ...
93.  
94. (define (state-lowlevel th init)
95.   (let handle ([r (reset (Done (th)))]
96.                [s init]) ;; can more efficiently thread resources
97.     (match r
98.       [(Done x) (cons x s)]
99.       [(Eff (State:Get) k) (handle (k s) s)]
100.       [(Eff (State:Set s) k) (handle (k) s)]
101.       [(Eff u k) (handle (k (perform u)) s)])))
102.  
103.  
104. (define (amb-lowlevel th)
105.   (let handle ([r (reset (Done (th)))])
106.     (match r
107.       [(Done x) (list x)]
108.       [(Eff (Amb xs) k) (append-map (lambda (x) (handle (k x))) xs)]
109.       [(Eff u k) (handle (k (perform u)))])))
110.  
111. (define (test)
112.   (let ([s1 (get)])
113.     (set (+ s1 (amb 1 2 3)))
114.     (cons (amb 1 2 3) (get))))
115.  
116. (amb-lowlevel
117.  (lambda ()
118.    (state-lowlevel test 1)))
119. ;; '(((1 . 2) . 2)
120. ;;   ((2 . 2) . 2)
121. ;;   ((3 . 2) . 2)
122. ;;   ((1 . 3) . 3)
123. ;;   ((2 . 3) . 3)
124. ;;   ((3 . 3) . 3)
125. ;;   ((1 . 4) . 4)
126. ;;   ((2 . 4) . 4)
127. ;;   ((3 . 4) . 4))

=>

eval:5:0: match: syntax error in pattern

in: (State:Get)

run-state: undefined;

cannot reference an identifier before its definition

in module: 'm

run-state: undefined;

cannot reference an identifier before its definition

in module: 'm

'(((1 . 2) . 2)   ((2 . 2) . 2)   ((3 . 2) . 2)   ((1 . 3) . 3)   ((2 . 3) . 3)   ((3 . 3) . 3)   ((1 . 4) . 4)   ((2 . 4) . 4)   ((3 . 4) . 4))