Yesterday and today I’ve spent few hours playing with an idea of BDD for Common Lisp. What for? Well, lets say “just for fun”. I’ve developed quick-and-dirty implementation of few bits of BDD, in the way similar to RSpec
Here you are:
;; Utilities
(defmethod obj->string ((s string))
s)
(defmethod obj->string ((s symbol))
(string s))
(defun concat-symbol (&rest args)
(intern (apply #'concatenate 'string
(mapcar #'string-upcase (mapcar #'obj->string args)))))
(defun respond-to? (o method &rest args)
(restart-case
(handler-bind ((undefined-function #'(lambda (c)
(declare (ignore c))
(invoke-restart 'no)))
(simple-error #'(lambda (c)
(declare (ignore c))
(invoke-restart 'no))))
(symbol-function method)
t)
(no (&optional v)
nil)))
;; Conditions
(define-condition expectation-not-met ()
())
;; Expectations
(defclass expectation ()
((expr :initarg :expr :reader expression-of)
(args :initarg :args :reader args-of)))
(defclass should (expectation)
())
(defgeneric fulfills? (expectation))
(defmethod fulfills? ((e should))
(flet ((match (matcher-class args expr)
(restart-case
(handler-bind ((simple-error #'(lambda (c)
(declare (ignore c))
(invoke-restart 'fun))))
(matches? (make-instance matcher-class :args args) expr))
(fun (&optional v)
(apply matcher-class (append (list (eval expr)) args))))))
(with-slots (args expr) e
(if (equal (car args) 'not)
(not (match (cadr args) (cddr args) expr))
(match (car args) (cdr args) expr)))))
;; Matchers
(defclass matcher ()
((args :initarg :args :reader args-of)))
(defclass be (matcher)
())
(defmethod initialize-instance :after ((matcher be) &rest initargs)
(declare (ignore initargs))
(with-slots (args) matcher
(when (equal (car args) 'a)
(pop args))))
(defgeneric matches? (matcher expr))
(defmethod matches? ((matcher be) expr)
(with-slots (args) matcher
(let* ((arguments (cdr args))
(message-forms (mapcar #'(lambda (suffix)
(concat-symbol (car args) suffix)) '("" "p" "-p" "?"))))
(when (equal (car arguments) 'of)
(pop arguments)) ;; am I crazy?
(dolist (form message-forms)
(when (respond-to? expr form arguments)
(return (eval `(,form ,expr ,@arguments))))))))
(defclass raise (matcher)
())
(defmethod matches? ((matcher raise) expr)
(with-slots (args) matcher
(restart-case
(handler-bind ((t #'(lambda (c)
(declare (ignore c))
(if (equal (class-of c) (find-class (car args)))
(invoke-restart 'raises)
(invoke-restart 'donot)))))
(eval `(progn
(eval ,expr)))
nil)
(raises (&optional v) t)
(donot (&optional v) nil))))
;;
(defmacro => (form &rest specification)
(let ((expectation-class (car specification))
(args (cdr specification)))
`(let* ((result ',form)
(expectation (make-instance ',expectation-class
:expr result
:args ',args)))
(unless (fulfills? expectation)
(error (make-instance 'expectation-not-met)))
result)))
;; Grouping
(defmacro define-with-spec-grouping (name)
(let ((with-grouping (concat-symbol "with-" name ))
(spec-groupings (concat-symbol "*spec-" name "s*"))
(spec-grouping (concat-symbol "*spec-" name "*")))
`(defmacro ,with-grouping (grouping-name &body body)
`(progn
(unless (and (boundp ',',spec-groupings) (listp ,',spec-groupings))
(defvar ,',spec-groupings nil))
(let* ((,',spec-groupings (cons ,grouping-name ,',spec-groupings))
(,',spec-grouping (car ,',spec-groupings)))
,@body)))))
(define-with-spec-grouping context)
(define-with-spec-grouping aspect)
(defmacro specify (name &body body)
`(let ((*spec-specification* ,name))
,@body))
It allows me to write constructs like:
CL-USER> (=> (1+ 1) should = 2)
2
CL-USER> (=> (1+ 1) should not be zero)
2
CL-USER> (=> 0 should not be zero)
; Exception raised
CL-USER> (=> (+ 2 2) should = 5)
; Exception raised
CL-USER> (=> 1 should be a member of '(1 2 3))
1
CL-USER> (=> 0 should be a member of '(1 2 3))
; Exception raised
CL-USER> (=> (=> 1 should = 0) should raise expectation-not-met)
(=> 1 SHOULD = 0)
CL-USER> (=> (=> 1 should = 1) should not raise expectation-not-met)
(=> 1 SHOULD = 1)
CL-USER> (=> (=> 1 should = 1) should raise expectation-not-met)
; Exception raised
and play with contexts, aspects and specifications.
It was funny.
