├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── README.org ├── salmon.asd ├── src ├── either.lisp ├── maybe.lisp ├── mlist.lisp ├── monad.lisp ├── mvector.lisp └── try.lisp └── tests ├── either-tests.lisp ├── maybe-tests.lisp ├── mlist-tests.lisp ├── monad-tests.lisp ├── mvector-tests.lisp └── try-tests.lisp /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push] 4 | 5 | jobs: 6 | test: 7 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 8 | runs-on: ${{ matrix.os }} 9 | strategy: 10 | matrix: 11 | lisp: [sbcl-bin, ccl-bin] 12 | os: [ubuntu-22.04] 13 | 14 | steps: 15 | - uses: actions/checkout@v1 16 | - name: Install Roswell 17 | env: 18 | LISP: ${{ matrix.lisp }} 19 | ROSWELL_INSTALL_DIR: /usr 20 | run: | 21 | wget https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh 22 | chmod +x ./install-for-ci.sh 23 | ./install-for-ci.sh 24 | 25 | - name: Download dissect 26 | run: | 27 | wget -q -O- https://dist.shirakumo.org/archives/dissect/dissect-a70cabcd748cf7c041196efd711e2dcca2bbbb2c.tgz | tar -xz -C ~/.roswell/local-projects 28 | 29 | - name: Install Rove 30 | run: ros install rove 31 | 32 | - name: Run tests 33 | run: | 34 | PATH="~/.roswell/bin:$PATH" 35 | rove salmon.asd 36 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | [[https://github.com/HenryS1/salmon/tree/master][https://github.com/HenryS1/salmon/actions/workflows/ci.yaml/badge.svg]] 2 | 3 | * Salmon 4 | 5 | An extensible foundation for monads in Common Lisp. 6 | 7 | ** Why does Lisp need Monads? 8 | 9 | Monads provide a uniform interface to control flow for a variety of 10 | different computations. 11 | 12 | Error handling, missing values, asynchronous computation, parsing and 13 | more can be modelled with monads. 14 | 15 | The term monads is used somewhat loosely in the context of this 16 | library which only requires candidate monads to implement ~fmap~ and 17 | ~flatmap~. 18 | 19 | ** Comprehensions 20 | 21 | Salmon uses an implementation of fmap and flatmap to provide a do syntax 22 | similar to do comprehensions in Haskell and for comprehensions in 23 | Scala. 24 | 25 | In Haskell a monad comprehension looks like this: 26 | 27 | #+begin_src haskell 28 | do 29 | a <- [1,2,3] 30 | let c = 5 31 | b <- [4,5] 32 | return (a + b + c) 33 | #+end_src 34 | 35 | The same pattern is expressed in salmon with 36 | 37 | #+begin_src lisp 38 | (mdo (a '(1 2 3)) 39 | (let (c 5)) 40 | (b '(4 5)) 41 | (yield (+ a b c))) 42 | #+end_src 43 | 44 | The ~mdo~ macro desugars to nested applications of ~fmap~ and 45 | ~flatmap~. 46 | 47 | ** The analogy between generic methods and type classes 48 | 49 | Lisp's generic methods can be implemented on data separate from the 50 | definition of that data. This allows generic methods to fulfill a 51 | similar to type classes from Haskell. The main difference is that 52 | typeclasses force the implementor to provide all methods in a contract 53 | while generic methods can be implemented one by one for any data type. 54 | 55 | ** Builtin implementations 56 | 57 | Salmon comes with builtin monad implementations for 58 | 59 | *** Maybe 60 | 61 | Maybe provides a way to handle missing values. ~just~ for when a value 62 | is present and nil for a missing value. An ~mdo~ comprehension 63 | shortcircuits on nil. 64 | 65 | #+begin_src lisp 66 | (mdo (a (maybe:just 15)) 67 | (b (maybe:just 4)) 68 | (yield (+ a b))) 69 | ;; # 70 | #+end_src 71 | 72 | *** Try 73 | 74 | Try wraps any conditions in a value to instead of having them 75 | propagate. The ~try~ macro can be used to handle any conditions. The 76 | value of the expression is a ~failure~ if a condition occurred and 77 | otherwise it is a ~success~ with the final value provided in the 78 | expression (~try~ provides an implicit ~progn~). 79 | 80 | #+begin_src lisp 81 | (try:try (let ((a 10) 82 | (b 0)) 83 | (/ a b))) 84 | ; # 86 | #+end_src 87 | 88 | #+RESULTS: 89 | : # 91 | 92 | In an ~mdo~ comprehension try shortcircuits on failures. 93 | 94 | #+begin_src lisp 95 | (mdo (a (try:success 15)) 96 | (b (try:success 4)) 97 | (yield (+ a b))) 98 | ;; # 99 | #+end_src 100 | 101 | #+RESULTS: 102 | 103 | 104 | *** List 105 | 106 | A ~list~ monad comprehension is shortcuited by the empty ~list~. The 107 | result of a ~list~ monad comprehension uses all combinations of values 108 | from the unwrapped lists. 109 | 110 | #+begin_src lisp 111 | (mdo (a '(1 2 3)) 112 | (b '(4 5 6)) 113 | (yield (+ a b))) 114 | ;; (5 6 7 6 7 8 7 8 9) 115 | #+end_src 116 | 117 | *** Vector 118 | 119 | A ~vector~ monad comprehension is shortcircuited by the empty 120 | ~vector~. As with lists a ~vector~ monad comprehension uses all 121 | combinations of values from the unwrapped vectors. 122 | 123 | #+begin_src lisp 124 | (mdo (a #(1 2 3)) 125 | (b #(4 5 6)) 126 | (yield (+ a b))) 127 | ;; #(5 6 7 6 7 8 7 8 9) 128 | #+end_src 129 | 130 | *** Either 131 | 132 | The either monad provides a mechanism for error handling holding 133 | either an error, in the left case, or a value, in the right case. 134 | 135 | #+begin_src lisp 136 | (mdo (a (right 10)) 137 | (b (right 5)) 138 | (yield (+ a b))) 139 | ;; # 140 | (mdo (a (right 10)) 141 | (b (left "error")) 142 | (yield (+ a b))) 143 | ;; # 144 | #+end_src 145 | -------------------------------------------------------------------------------- /salmon.asd: -------------------------------------------------------------------------------- 1 | (defsystem "salmon" 2 | :version "1.0.0" 3 | :author "Henry Steere" 4 | :license "MIT" 5 | :components ((:module "src" 6 | :components 7 | ((:file "monad") 8 | (:file "maybe" :depends-on ("monad")) 9 | (:file "try" :depends-on ("monad")) 10 | (:file "mlist" :depends-on ("monad")) 11 | (:file "mvector" :depends-on ("monad")) 12 | (:file "either" :depends-on ("monad"))))) 13 | :description "Provides monad comprehensions in Common Lisp" 14 | :in-order-to ((test-op (test-op "salmon/tests")))) 15 | 16 | (defsystem "salmon/tests" 17 | :depends-on ("rove" 18 | "salmon") 19 | :components ((:module "tests" 20 | :components 21 | ((:file "maybe-tests") 22 | (:file "try-tests") 23 | (:file "monad-tests") 24 | (:file "mlist-tests") 25 | (:file "mvector-tests") 26 | (:file "either-tests")))) 27 | :perform (test-op (o c) (symbol-call :rove '#:run c))) 28 | -------------------------------------------------------------------------------- /src/either.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :either 2 | (:use :cl :monad) 3 | (:import-from :monad :fmap :flatmap) 4 | (:export :right :left :value :err :if-absent)) 5 | 6 | (in-package :either) 7 | 8 | (defstruct (left (:constructor left (err)) (:conc-name)) err) 9 | (defstruct (right (:constructor right (value)) (:conc-name)) value) 10 | 11 | (defun if-absent (v err) (or (and v (right v)) (left err))) 12 | 13 | (defmethod print-object ((left left) out) 14 | (print-unreadable-object (left out :type t) 15 | (format out "~a" (err left)))) 16 | 17 | (defmethod print-object ((right right) out) 18 | (print-unreadable-object (right out :type t) 19 | (format out "~a" (value right)))) 20 | 21 | (defmethod fmap (fun (left left)) left) 22 | 23 | (defmethod fmap (fun (right right)) 24 | (right (funcall fun (value right)))) 25 | 26 | (defmethod flatmap (fun (left left)) left) 27 | 28 | (defmethod flatmap (fun (right right)) 29 | (funcall fun (value right))) 30 | -------------------------------------------------------------------------------- /src/maybe.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :maybe 2 | (:use :cl :monad) 3 | (:import-from :monad :fmap :flatmap) 4 | (:export :value 5 | :just)) 6 | 7 | (in-package :maybe) 8 | 9 | (defstruct (just (:constructor just (value)) (:conc-name)) value) 10 | 11 | (defmethod print-object ((just just) out) 12 | (print-unreadable-object (just out :type t) 13 | (format out "~a" (value just)))) 14 | 15 | (defmethod fmap (fun (v (eql nil))) v) 16 | 17 | (defmethod fmap (fun (just just)) 18 | (just (funcall fun (value just)))) 19 | 20 | (defmethod flatmap (fun (v (eql nil))) v) 21 | 22 | (defmethod flatmap (fun (just just)) 23 | (funcall fun (value just))) 24 | -------------------------------------------------------------------------------- /src/mlist.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :mlist 2 | (:use :cl :monad)) 3 | 4 | (in-package :mlist) 5 | 6 | (defmethod fmap (fun (l list)) 7 | (mapcar fun l)) 8 | 9 | (defmethod flatmap (fun (l list)) 10 | (apply #'append (mapcar fun l))) 11 | -------------------------------------------------------------------------------- /src/monad.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :monad 2 | (:use :cl) 3 | (:export :mdo 4 | :fmap 5 | :flatmap)) 6 | 7 | (in-package :monad) 8 | 9 | (defgeneric flatmap (fun obj)) 10 | 11 | (defgeneric fmap (fun obj)) 12 | 13 | (defun ignore-underscore (name) 14 | (if (equal (symbol-name name) (symbol-name '_)) (list `(declare (ignore ,name))) ())) 15 | 16 | (defun transform-clause (acc clause) 17 | (destructuring-bind (clauses . seen-unwrap) acc 18 | (cond ((eq (car clause) 'let) 19 | (cons (append `(let ,(cdr clause) 20 | ,@(ignore-underscore (caadr clause))) (list clauses)) 21 | seen-unwrap)) 22 | ((equal (symbol-name (car clause)) (symbol-name 'handle)) 23 | (cons `(handler-case 24 | ,clauses 25 | (,(cadr clause) ,(caddr clause) ,@(cdddr clause))) 26 | seen-unwrap)) 27 | ((equal (symbol-name (car clause)) (symbol-name 'with)) 28 | (if (not seen-unwrap) 29 | (cons `(fmap (lambda (,(caddr clause)) 30 | ,@(ignore-underscore (caddr clause)) 31 | (unwind-protect 32 | ,clauses 33 | (funcall ,(cadr clause) ,(caddr clause)))) 34 | (progn ,@(cdddr clause))) 35 | t) 36 | (cons `(flatmap (lambda (,(caddr clause)) 37 | ,@(ignore-underscore (caddr clause)) 38 | (unwind-protect 39 | ,clauses 40 | (funcall ,(cadr clause) ,(caddr clause)))) 41 | (progn ,@(cdddr clause))) 42 | seen-unwrap))) 43 | ((equal (symbol-name (car clause)) (symbol-name 'clean-on-error)) 44 | (let ((e (gensym))) 45 | (if (not seen-unwrap) 46 | (cons `(fmap (lambda (,(caddr clause)) 47 | (handler-case 48 | ,clauses 49 | (error (,e) 50 | (funcall ,(cadr clause) ,(caddr clause)) 51 | (error ,e)))) 52 | (progn ,@(cdddr clause))) 53 | t) 54 | (cons `(flatmap (lambda (,(caddr clause)) 55 | (handler-case 56 | ,clauses 57 | (error (,e) 58 | (funcall ,(cadr clause) ,(caddr clause)) 59 | (error ,e)))) 60 | (progn ,@(cdddr clause))) 61 | seen-unwrap)))) 62 | ((not seen-unwrap) 63 | (cons `(fmap (lambda (,(car clause)) 64 | ,@(ignore-underscore (car clause)) 65 | ,clauses) 66 | (progn ,@(cdr clause))) 67 | t)) 68 | (t (cons `(flatmap (lambda (,(car clause)) 69 | ,@(ignore-underscore (car clause)) 70 | ,clauses) (progn ,@(cdr clause))) 71 | seen-unwrap))))) 72 | 73 | (defun check-clauses (exps) 74 | (when (not (string= (caar (last exps)) "YIELD")) 75 | (error "The final clause in mdo must be a yield"))) 76 | 77 | (defun transform-mdo (exps) 78 | (let ((reversed (reverse exps))) 79 | (car (reduce #'transform-clause (cdr reversed) 80 | :initial-value (cons `(progn ,@(cdr (car reversed))) nil))))) 81 | 82 | (defmacro mdo (&rest exps) 83 | (check-clauses exps) 84 | (transform-mdo exps)) 85 | -------------------------------------------------------------------------------- /src/mvector.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :mvector 2 | (:use :cl :monad)) 3 | 4 | (in-package :mvector) 5 | 6 | (defmethod fmap (fun (v vector)) 7 | (map 'vector fun v)) 8 | 9 | (defmethod flatmap (fun (v vector)) 10 | (let* ((vs (fmap fun v)) 11 | (result (make-array (reduce (lambda (a b) (+ a (length b))) vs :initial-value 0)))) 12 | (loop with i = 0 13 | for v across vs 14 | do (loop for el across v 15 | do (setf (aref result i) el) 16 | (incf i))) 17 | result)) 18 | -------------------------------------------------------------------------------- /src/try.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :try 2 | (:use :cl :monad) 3 | (:import-from :monad :fmap :flatmap) 4 | (:export :success 5 | :try 6 | :failure 7 | :value)) 8 | 9 | (in-package :try) 10 | 11 | (defclass try () ()) 12 | 13 | (defclass success (try) 14 | ((value :accessor value :initarg :value :initform (error "value must be provided")))) 15 | 16 | (defclass failure (try) 17 | ((value :accessor value :initarg :value :initform (error "value must be provided")))) 18 | 19 | (defun success (v) 20 | (make-instance 'success :value v)) 21 | 22 | (defun failure (v) 23 | (make-instance 'failure :value v)) 24 | 25 | (defmacro try (&rest exps) 26 | `(handler-case (success (progn ,@exps)) 27 | (t (e) () (failure e)))) 28 | 29 | (defmethod print-object ((success success) out) 30 | (print-unreadable-object (success out :type t) 31 | (format out "~a" (value success)))) 32 | 33 | (defmethod print-object ((failure failure) out) 34 | (print-unreadable-object (failure out :type t) 35 | (format out "~a" (value failure)))) 36 | 37 | (defmethod fmap (fun (s success)) 38 | (success (funcall fun (value s)))) 39 | 40 | (defmethod flatmap (fun (s success)) 41 | (funcall fun (value s))) 42 | 43 | (defmethod fmap (fun (f failure)) f) 44 | 45 | (defmethod flatmap (fun (f failure)) f) 46 | -------------------------------------------------------------------------------- /tests/either-tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :either-tests 2 | (:use :cl :rove :either)) 3 | 4 | (in-package :either-tests) 5 | 6 | (deftest fmap-test 7 | (testing "fmap leaves left unchanged" 8 | (let ((fun (lambda (x) (+ x 1)))) 9 | (ok (equalp (monad:fmap fun (left "an error")) (left "an error"))))) 10 | (testing "fmap applies a function to the value in a right" 11 | (let ((fun (lambda (x) (+ x 1)))) 12 | (ok (equalp (monad:fmap fun (right 10)) (right 11)))))) 13 | 14 | (deftest flatmap-test 15 | (testing "flatmap leaves left unchanged" 16 | (let ((fun (lambda (x) (right (+ x 1))))) 17 | (ok (equalp (monad:flatmap fun (left "an error")) (left "an error"))))) 18 | (testing "flatmap flattens the result of applying a function to the value in a right" 19 | (let ((fun (lambda (x) (right (+ x 1))))) 20 | (ok (equalp (monad:flatmap fun (right 10)) (right 11)))) 21 | (let ((fun (lambda (x) (declare (ignore x)) (left "an error")))) 22 | (ok (equalp (monad:flatmap fun (right 10)) (left "an error")))))) 23 | 24 | (deftest if-absent 25 | (let ((table (make-hash-table :test 'equal))) 26 | (setf (gethash "hello" table) "there") 27 | (testing "returns error value when option is nil" 28 | (ok (equalp (if-absent (gethash "absent" table) "not found") 29 | (left "not found")))) 30 | (testing "returns value when option is not nil" 31 | (ok (equalp (if-absent (gethash "hello" table) "not found") 32 | (right "there")))))) 33 | -------------------------------------------------------------------------------- /tests/maybe-tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :maybe-tests 2 | (:use :cl :rove :maybe)) 3 | 4 | (in-package :maybe-tests) 5 | 6 | (deftest just-test 7 | (testing "just-value is inverse of just" 8 | (ok (= (value (just 10)) 10)))) 9 | 10 | (deftest fmaptest 11 | (testing "fmap action on just and nothing" 12 | (ok (= (value (monad:fmap (lambda (x) (+ x 1)) (just 10))) 13 | 11) 14 | "fmap applies a function to the value in just") 15 | (ok (eq (monad:fmap (lambda (x) (+ x 1)) nil) nil) 16 | "fmap leaves nil as nil"))) 17 | 18 | (deftest flatmap-test 19 | (testing "flatmap action on just and nothing" 20 | (ok (typep (value (monad:flatmap #'just (just 10))) 'integer) 21 | "flatmap does not nest just") 22 | (ok (= (value (monad:flatmap (lambda (x) (just (+ x 1))) (just 10))) 11) 23 | "flatmap applies a function to the value of just") 24 | (ok (eq (monad:flatmap (lambda (x) (+ x 1)) nil) nil) 25 | "flatmap leaves nil as nil"))) 26 | -------------------------------------------------------------------------------- /tests/mlist-tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :mlist-tests 2 | (:use :cl :rove :mlist)) 3 | 4 | (in-package :mlist-tests) 5 | 6 | (deftest fmap-test 7 | (testing "fmap works the same as mapcar" 8 | (let ((fun (lambda (x) (+ x 1)))) 9 | (ok (equal (monad:fmap fun '(1 2 3)) 10 | (mapcar fun '(1 2 3))))))) 11 | 12 | (deftest flatmap-test 13 | (testing "flatmap returns the elements in order" 14 | (ok (equal (monad:flatmap (lambda (x) (list 1 x)) '(2 3 4)) 15 | '(1 2 1 3 1 4))))) 16 | -------------------------------------------------------------------------------- /tests/monad-tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :monad-tests 2 | (:use :cl :rove :monad :either)) 3 | 4 | (in-package :monad-tests) 5 | 6 | (deftest test-mdo 7 | (testing "mdo processes maybe values" 8 | (ok (eq (mdo (a (maybe:just 10)) 9 | (b (maybe:just 11)) 10 | (c nil) 11 | (yield (+ a b c))) 12 | nil) 13 | "mdo short circuits when a nil value occurs") 14 | (ok (typep (mdo (a (maybe:just 6)) 15 | (b (maybe:just 4)) 16 | (yield (+ a b))) 17 | 'maybe:just) 18 | "mdo returns just when no nils occur in a comprehension") 19 | (ok (equalp (mdo (a (maybe:just 6)) 20 | (b (maybe:just 4)) 21 | (yield (+ a b))) 22 | (maybe:just 10)) 23 | "mdo unwraps values from just") 24 | (ok (equalp (mdo (a (maybe:just 7)) 25 | (let (b 2)) 26 | (yield (+ a b))) 27 | (maybe:just 9)) 28 | "mdo binds one value in a let clause") 29 | (ok (equalp (mdo (a (maybe:just 7)) 30 | (let (b 2) (c 1)) 31 | (yield (+ a b c))) 32 | (maybe:just 10)) 33 | "mdo binds multiple values in a let clause") 34 | (ok (equalp (mdo (a (maybe:just 7)) 35 | (let (b 3)) 36 | (c (maybe:just 2)) 37 | (let (d 1)) 38 | (e (maybe:just 9)) 39 | (yield (+ a b c d e))) 40 | (maybe:just 22)) 41 | "mdo binds values in multiple let clauses"))) 42 | 43 | (deftest error-handling 44 | (testing "mdo handles errors in a yield clause" 45 | (ok (equalp (mdo (handle division-by-zero () (left "Error occurred")) 46 | (a (right 0)) 47 | (yield (/ 10 a))) 48 | (left "Error occurred")))) 49 | (testing "mdo handles errors in a body clause" 50 | (ok (equalp (mdo (handle division-by-zero () (left "Error occurred")) 51 | (a (right (/ 1 0))) 52 | (b (right 2)) 53 | (yield (+ a b))) 54 | (left "Error occurred"))))) 55 | 56 | (deftest with-resource-management 57 | (testing "with clause calls tidy up function after executing without error" 58 | (let ((f (open "test.tst" :direction :output :if-exists :error))) 59 | (ok (probe-file "test.tst")) 60 | (ok (equalp 61 | (mdo (with (lambda (f) (progn (close f) (delete-file "test.tst"))) writer (right f)) 62 | (_ (format writer "hello~%") (right (finish-output writer))) 63 | (handle error (e) (left (format nil "Error reading file ~a" e))) 64 | (with #'close reader (right (open "test.tst" :direction :input))) 65 | (b (right (read-line reader nil nil))) 66 | (yield b)) 67 | (right "hello"))) 68 | (ok (not (probe-file "test.tst"))))) 69 | (testing "with clause calls tidy up function after executing with error" 70 | (let ((f (open "test.tst" :direction :output :if-exists :error))) 71 | (ok (probe-file "test.tst")) 72 | (ok (equalp 73 | (mdo (with (lambda (f) (progn (close f) (delete-file "test.tst"))) writer (right f)) 74 | (_ (format writer "hello~%") (right (finish-output writer))) 75 | (handle error () (left "Error occurred")) 76 | (with #'close reader (right (open "test.tst" :direction :input))) 77 | (a (right 0)) 78 | (_ (right (read-line reader nil nil))) 79 | (c (right (/ 1 a))) 80 | (yield c)) 81 | (left "Error occurred"))) 82 | (ok (not (probe-file "test.tst")))))) 83 | 84 | (deftest clean-on-error 85 | (testing "calls the tidy up function if an error occurs" 86 | (let ((f (open "test.tst" :direction :output :if-exists :error))) 87 | (ok (probe-file "test.tst")) 88 | (ok (equalp 89 | (mdo (handle error () (left "An error occurred")) 90 | (clean-on-error (lambda (f) (progn (close f) (delete-file "test.tst"))) 91 | writer (right f)) 92 | (_ (format writer "hello~%") (right (finish-output writer))) 93 | (c (right 0)) 94 | (b (right (/ 1 c))) 95 | (yield b)) 96 | (left "An error occurred"))) 97 | (ok (not (probe-file "test.tst"))))) 98 | (testing "doesn't call the tidy up function an no error occurs" 99 | (unwind-protect (let ((f (open "test.tst" :direction :output :if-exists :error))) 100 | (ok (probe-file "test.tst")) 101 | (ok (equalp 102 | (mdo (handle error () (left "An error occurred")) 103 | (clean-on-error (lambda (f) (progn (close f) (delete-file "test.tst"))) 104 | writer (right f)) 105 | (_ (format writer "hello~%") (right (finish-output writer))) 106 | (yield "ok")) 107 | (right "ok"))) 108 | (ok (probe-file "test.tst"))) 109 | (when (probe-file "test.tst") (delete-file "test.tst"))))) 110 | -------------------------------------------------------------------------------- /tests/mvector-tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :mvector-tests 2 | (:use :cl :rove :mvector)) 3 | 4 | (in-package :mvector-tests) 5 | 6 | (defun vector-equal (one other) 7 | (every (lambda (a b) (equal a b)) one other)) 8 | 9 | (deftest fmap-test 10 | (testing "fmap works the same as map 'vector" 11 | (let ((fun (lambda (x) (+ x 1)))) 12 | (ok (vector-equal (monad:fmap fun (vector 1 2 3)) 13 | (mapcar fun '(1 2 3))))))) 14 | 15 | (deftest flatmap-test 16 | (testing "flatmap returns the elements in order" 17 | (ok (vector-equal (monad:flatmap (lambda (x) (vector 1 x)) (vector 2 3 4)) 18 | (vector 1 2 1 3 1 4))))) 19 | -------------------------------------------------------------------------------- /tests/try-tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :try-tests 2 | (:use :cl :rove :try)) 3 | 4 | (in-package :try-tests) 5 | 6 | (define-condition a-test-condition (error) ()) 7 | 8 | (deftest try-test 9 | (testing "try handles errors in its body" 10 | (let ((v (try (error 'a-test-condition)))) 11 | (ok (typep v 'failure) 12 | "when a condition occurs a try returns failure") 13 | (ok (typep (value v) 'a-test-condition) 14 | "when a condition occurs the value in the failure is the condition")) 15 | (let ((v (try 10))) 16 | (ok (typep v 'success) 17 | "when no condition occurs a try returns success") 18 | (ok (= (value v) 10) 19 | "when no condition occurs the value of the expression is returned in a success")))) 20 | 21 | (deftest fmap-test 22 | (testing "fmap action on success and failure" 23 | (ok (= (value (monad:fmap (lambda (x) (+ x 1)) (success 10))) 11) 24 | "fmap applies a function to the value in success") 25 | (let ((v (try (error 'a-test-condition)))) 26 | (ok (eq (monad:fmap (lambda (x) (+ x 1)) v) v) 27 | "fmap leaves a failure unchanged")))) 28 | 29 | (deftest flatmap-test 30 | (testing "flatmap action on success and failure" 31 | (ok (typep (value (monad:flatmap (lambda (x) (success (+ x 1))) (success 10))) 'integer) 32 | "flatmap does not nest successes") 33 | (ok (= (value (monad:flatmap (lambda (x) (success (+ x 1))) (success 10))) 11) 34 | "flatmap applies a function the value of a success") 35 | (let ((v (try (error 'a-test-condition)))) 36 | (ok (eq (monad:flatmap (lambda (x) (+ x 1)) v) v) 37 | "flatmap leaves a failure unchanged")))) 38 | --------------------------------------------------------------------------------