Monadic reflection/reification in Racket using delimited control

ndet.rkt

#lang racket

(require "reflection.rkt")

; unit : x -> [x]
(define unit (lambda (x) (cons x '())))

; bind : [x] -> (x -> [y]) -> [y]
(define bind (lambda (m f) (apply append (map f m))))

; fail : [x]
(define fail '())

; or : [x] -> [x] -> [x]
(define or (lambda (x y) (append x y)))

; only-head : [x] -> [x]
(define only-head
  (lambda (l)
    (if (null? l)
        l
        (cons (car l) '()))))


; A simple program written in the monadic style:
(define prog-m
  (bind (or (unit 1) (unit 2))
        (lambda (n)
          (bind (or (unit 3) (unit 4))
                (lambda (m)
                  (unit (+ n m)))))))


; reflect : [v] ->ND v
(define reflect
  (reflectMonad unit bind))

; reify : (() ->ND v) -> [v]
(define reify
  (reifyMonad unit bind))

; coin : () ->ND Bool
(define coin
  (lambda () (reflect (or (unit #t)
                          (unit #f)))))

(reify coin)
;(#t #f)

; once' : (() ->ND v) ->ND v
(define once
  (lambda (c) (reflect (only-head (reify c)))))

; select : [a] ->ND a
(define (select l)
  (if (= 1 (length l))
      (car l)
      (if (coin)
          (car l)
          (select (cdr l)))))

; A simple macro expanding (ndet x) to (reify (lambda () x))
; Inside this macro nondeterminism behaves like native effects.
(define-syntax-rule (ndet x)
  (reify (lambda () x)))

(ndet (+ (select '(1 2 3 4))
         (select '(5 6 7 8))))

(ndet (+ (select '(1 2 3 4))
         (select '(5 6 7 8))))

(ndet (+ (select '(1 2 3 4))
         (once (lambda () (select '(5 6 7 8))))))

reflection.rkt

#lang racket

(require racket/control)

(provide reifyMonad)

(provide reflectMonad)

; reify : (1 ->T v) -> Tv
(define reifyMonad
  (lambda (unit bind)
    (lambda (v) (reset (unit (v))))))

; reflect : Tv ->T v
(define reflectMonad
  (lambda (unit bind)
    (lambda (m) (shift k (bind m k)))))