;;;; 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