Yurii Rashkovskii's Blog

I’ve created a small umbrella project for BDD implementations I’m playing with (Common Lisp and Erlang by now).

Few days ago I’ve hacked a simplistic BDD for Common Lisp. I’m still having fun improving it. Here you are an improved respond-to? that supports generics much better.

 
  (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))))
    (let ((sf (symbol-function method))
          (cpl (sb-pcl::class-precedence-list (class-of o))))
      (typecase sf
        (standard-generic-function
         (find t 
           (mapcar #'(lambda (klass)
                   (not (null
                     (find-method sf '() 
                          (cons klass
                            (mapcar #'(lambda (c) (declare (ignore c)) t) args)) nil))))
               cpl)))
        (function t))))
    (no (&optional v)
      nil)))
 

Though for non-generic functions there seems to be no way to check if actually object “responds” to function without actually evaluating it.

Anyway, it’s quite funny!

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.