76 lines
1.6 KiB
Racket
76 lines
1.6 KiB
Racket
|
#lang racket
|
||
|
|
|
||
|
|
(provide left right left? right? squash
|
||
|
|
>>= return reduce <*> e-map do)
|
||
|
|
|
||
|
|
(struct either (tag value))
|
||
|
|
|
||
|
|
(define (left val)
|
||
|
|
(either 'left val))
|
||
|
|
|
||
|
|
(define (right val)
|
||
|
|
(either 'right val))
|
||
|
|
|
||
|
|
(define (left? val)
|
||
|
|
(and (either? val) (eq? (either-tag val) 'left)))
|
||
|
|
|
||
|
|
(define (right? val)
|
||
|
|
(not (left? val)))
|
||
|
|
|
||
|
|
(define (>>= e f)
|
||
|
|
(if (eq? (either-tag e) 'left)
|
||
|
|
e
|
||
|
|
(f (either-value e))))
|
||
|
|
|
||
|
|
(define (return x)
|
||
|
|
(right x))
|
||
|
|
|
||
|
|
(define (reduce f-left f-right e)
|
||
|
|
(if (eq? (either-tag e) 'left)
|
||
|
|
(f-left (either-value e))
|
||
|
|
(f-right (either-value e))))
|
||
|
|
|
||
|
|
(define (<*> f e)
|
||
|
|
(cond
|
||
|
|
((eq? 'left (either-tag f))
|
||
|
|
f)
|
||
|
|
((eq? 'left (either-tag e))
|
||
|
|
e)
|
||
|
|
(else
|
||
|
|
(right ((either-value f) (either-value e))))))
|
||
|
|
|
||
|
|
(define (e-map f e)
|
||
|
|
(if (eq? 'left (either-tag e))
|
||
|
|
e
|
||
|
|
(right (f (either-value e)))))
|
||
|
|
|
||
|
|
(define (squash e)
|
||
|
|
(if (and (right? e) (either? (either-value e)))
|
||
|
|
(either-value e)
|
||
|
|
e))
|
||
|
|
|
||
|
|
; (do
|
||
|
|
; (<- var1 exp1)
|
||
|
|
; (exp2)
|
||
|
|
; (let var2 exp3)
|
||
|
|
; (return var2))
|
||
|
|
;
|
||
|
|
; -->
|
||
|
|
; (>>= exp1 (lambda (var1) (exp2) (let ((var2 exp3)) (return var2))))
|
||
|
|
|
||
|
|
(define-syntax (do stx)
|
||
|
|
(define (do->lambda exprs)
|
||
|
|
(define expr (car exprs))
|
||
|
|
(cond
|
||
|
|
((and (pair? expr) (eq? (car expr) '<-))
|
||
|
|
`(>>= ,(caddr expr) (lambda (,(cadr expr)) ,(do->lambda (cdr exprs)))))
|
||
|
|
((and (pair? expr) (eq? (car expr) 'let))
|
||
|
|
`(let ((,(cadr expr) ,(caddr expr))) ,(do->lambda (cdr exprs))))
|
||
|
|
((null? (cdr exprs))
|
||
|
|
expr)
|
||
|
|
(else
|
||
|
|
`(begin ,expr ,(do->lambda (cdr exprs))))))
|
||
|
|
(let* ((ast (syntax->datum stx))
|
||
|
|
(transformed (do->lambda (cdr ast))))
|
||
|
|
(datum->syntax stx transformed)))
|