Skip to content

Instantly share code, notes, and snippets.

@leque
Last active May 11, 2016 01:35
Show Gist options
  • Save leque/a72a9839b91ebb496185 to your computer and use it in GitHub Desktop.
Save leque/a72a9839b91ebb496185 to your computer and use it in GitHub Desktop.
Freer monad in Scheme
;;;; 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment