;;;; fauxnads.lisp -- toy monads in Common Lisp ;; DOWNLOAD this file directly here: http://cicadas.surf/pastebin/fauxnads.lisp (defpackage #:fauxnads (:use #:cl) (:export #:bind #:ret #:fauxdo #:run-maybe #:run-state #:run-reader)) (in-package #:fauxnads) ;;; Monad Interface ;;; ;; bind :: m a -> (a -> m b) -> m b (defun bind (ma a->mb) (error "BIND Not Called In A Monadic Context.")) ;; ret :: a -> m a (defun ret (a) (error "RET Not Called In A Monadic Context.")) ;;; Laziness Legwork ;;; ;; newtype around thunks (defstruct lazy-value thunk) (defmacro lazy (&rest forms) "Creates a LAZY-VALUE from a sequence of FORMS. You can use FORCE to get the value of the forms as if evaluated in a PROGN form. Using FORCE a second time will return a cached value." (let ((cache (gensym)) (runp (gensym))) `(let (,cache ,runp) (make-lazy-value :thunk (lambda () (if ,runp ,cache (setf ,runp t ,cache (progn ,@forms)))))))) (defun force (lz) "Force the LAZY-VALUE. If LZ is nto a LAZY-VALUE, just return it." (if (lazy-value-p lz) (funcall (lazy-value-thunk lz)) lz)) ;;; The 'do' Macro ;;; (defmacro fauxdo (&rest ops) "FAUXDO is a way to use an imperative style to construct programs that evaluate in a monadic context. OPS is a list, each member of which is either a variable capture form or a monadic operation. Variable capture forms look like: (:<- VAR OPERATION) OPERATION is any form that evaluates to member of the monad. Examples should make it clearer. Once a variable is bound, later operations can refer to it. FAUXDO returns a thunk." (let ((program (reduce (lambda (expansion form) (cond ((and (listp form) (eql :<- (first form))) (destructuring-bind (variable op) (rest form) `(fauxnads:bind (force ,op) (lambda (,variable) (force ,expansion))))) (t `(fauxnads:bind (force ,form) (lambda (ignore) (declare (ignore ignore)) (force ,expansion)))))) (reverse ops)))) `(lazy ,program))) ;;; DYNAMIC-FLET ;;; (defmacro dynamic-flet ((name args &rest body) &body forms) "Dynamically rebind a currently bound function to some new value. Old function value is safely restored via UNWIND-PROTECT when the form exits." (let ((old-function (gensym))) `(let ((,old-function (symbol-function ',name))) (unwind-protect (progn (setf (symbol-function ',name) (function (lambda ,args ,@body))) ,@forms) (setf (symbol-function ',name) ,old-function))))) ;;; Maybe Monad ;;; (defun run-maybe (program) "Maybe Monad " (dynamic-flet (ret (a) (list a)) (dynamic-flet (bind (maybe-a a->maybe-b) (when maybe-a (funcall a->maybe-b (first maybe-a)))) (force (force program))))) ;;; Reader Monad ;;; (defvar ask #'identity "Ask for the current environemnt") (defun select (env->a) "Runs a selector function on the environment" (fauxdo (:<- env ask) (ret (funcall env->a env)))) (defun run-reader (env program) "Run the reader PROGRAM with the environment ENV" (dynamic-flet (ret (a) (lambda (env) (declare (ignore env)) a)) (dynamic-flet (bind (reader-a a->reader-b) (lambda (env) (let* ((a (funcall (force reader-a) env)) ; reader-a may be lazy (reader-b (funcall a->reader-b a))) (funcall (force reader-b) env)))) ; reader-b may also be lazy (funcall (force (force program)) env)))) ; this double force is awkward ;;; State Monad ;;; ;; take :: m s == State s s == s -> (s, s) (defvar take "Get the current state" (lambda (state) (values state state))) ;; put :: s -> m () == s -> State s () == s -> (s -> ((), s)) (defun put (new-state) "Update the state with a new value, returning nothing." (lambda (state) (declare (ignore state)) (values nil new-state))) (defun run-state (init-state program) "Run the PROGRAM with initial state INIT0STATE" (dynamic-flet (ret (a) (lambda (state) (values a state))) (dynamic-flet (bind (state-a a->state-b) (lambda (state) (multiple-value-bind (result new-state) (funcall state-a state) (funcall (funcall a->state-b result) new-state)))) (funcall (force (force program)) init-state)))) ;;; EXAMPLES ;;; ;; Example 1, constructing programs with FAUXDO ;; show how programs can be built up out of smaller parts (defvar add-1 "Increments the current value of the state" (fauxdo (:<- current-state take) (put (1+ current-state)))) (defvar add-3 (fauxdo add-1 add-1 add-1)) ;; add-3 really is a complete "program" that must be executed in the ;; right context, in this case, the State Monad. (run-state 0 add-3) ; returns (values NIL 3) ;; Example 2, failure propagation with the Maybe Monad (defun maybe-elt (n seq) "If it exists, get the nth member of the sequence SEQ. Returns (X) or NIL, where X is the nth element." (when (< n (length seq)) (ret (elt seq n)))) ;; this one succeeds with a value (let ((xs (list 1 2 3 4 5 6))) (run-maybe (fauxdo (:<- x (maybe-elt 4 xs)) (ret (+ x 100))))) ;; (105) ;; this one fails with NIL, the failure propagates through the ;; computation (let ((xs (list 1 2 3 4 5 6))) (run-maybe (fauxdo (:<- x (maybe-elt 200 xs)) ;; xs doesn't have a 200th element (ret (+ x 100))))) ;; NIL