Freer monad in Scheme

freer-monad.scm

;;;; Freer monad in Scheme
;;;; See also
;;;; * "Freer monads, more extensible effects"
;;;; http://dl.acm.org/citation.cfm?doid=2804302.2804319
;;;; * Free monad in Scheme https://gist.github.com/wasabiz/951b2f0b22643a59aeb2
(use gauche.record)
(use util.match)

;;; data Freer f a where
;;;   Pure   :: a -> Freer f a
;;;   Impure :: f x -> (x -> Freer f a) -> Freer f a
(define-record-type <pure> pure pure?
  (value pure-value))

(define-method write-object ((x <pure>) port)
  (format port "#<pure ~S>" (pure-value x)))

(define-record-type <impure> impure impure?
  (value impure-value)
  (continuation impure-continuation))

(define-method write-object ((x <impure>) port)
  (format port "#<impure ~S>"
          (impure-value x)))

(define (freer? x)
  (or (pure? x)
      (impure? x)))

;;; bind :: Freer f a -> (a -> Freer f b) -> Freer f b
(define (bind m k)
  (match m
    (($ <pure> v)
     (k v))
    (($ <impure> v k~)
     (impure v (kleisli>>> k~ k)))))

;;; kleisli>>> :: (a -> Freer f b) -> (b -> Freer f c) -> (a -> Freer f c)
(define (kleisli>>> f g)
  (lambda (x)
    (bind (f x) g)))

;;; lift :: f a -> Freer f a
(define (lift x)
  (impure x pure))

;;;; syntax
(use gauche.partcont)

(define-syntax reify
  (syntax-rules ()
    ((_ expr)
     (reset (pure expr)))))

(define (reflect m)
  (shift k
    (bind m k)))

(define (sequence ms)
  (reify
   (match ms
     (() '())
     ((mx . ms~)
      (let* ((x (reflect mx))
             (xs (reflect (sequence ms~))))
        (cons x xs))))))

(use srfi-1)

;;; run-list :: Free List a -> List a
(define (run-list m)
  (match m
    (($ <pure> v)
     (list v))
    (($ <impure> v k)
     (append-map (compose run-list k) v))))

(print
 (run-list
  (reify
   (let* ((x (reflect (lift '(1 2 3))))
          (y (reflect (lift '(a b c)))))
     (vector x y)))))
;; -| (#(1 a) #(1 b) #(1 c) #(2 a) #(2 b) #(2 c) #(3 a) #(3 b) #(3 c))

(print
 (run-list
  (sequence (list (lift '(1 2 3))
                  (lift '(4 5))))))
;; -| ((1 4) (1 5) (2 4) (2 5) (3 4) (3 5))

(print
 (run-list (sequence (list (pure 1) (pure 2)))))
;; -| ((1 2))

;;; (define-type (Option A) (U A False))
;;; run-option :: Free Option a -> Option a
(define (run-option m)
  (match m
    (($ <pure> v)
     v)
    (($ <impure> #f k)
     #f)
    (($ <impure> v k)
     (run-option (k v)))))

(print
 (run-option
  (reify
   (let* ((x (reflect (lift (find (cut eqv? <> 1) '(1 2 3)))))
          (y (reflect (lift (find (cut eqv? <> 'b) '(a b c))))))
     (vector x y)))))
;; -| #(1 b)

(print
 (run-option (sequence (list (pure 1) (pure 2)))))
;; -| (1 2)

(print
 (run-option (sequence (list (lift 1) (pure 2)))))
;; -| (1 2)

(print
 (run-option (sequence (list (lift 1) (pure #f)))))
;; -| (1 #f)

(print
 (run-option (sequence (list (lift #f) (pure 2)))))
;; -| #f

(print
 (run-option (sequence (list (pure 1) (lift #f)))))
;; -| #f

(exit)