[Common Lisp] cl-annotで契約による設計のようななにか

cl-annotのアノテーションを利用して、契約による設計(Design By Contrat)っぽいことを行ってみます。

(asdf:load-system :cl-annot)
(asdf:load-system :alexandria)

(defpackage net.phorni.contract
  (:use :cl)
  (:export
   ;; annotation
   contract
   ;; condtion
   contract-error
   pre-contract-error
   post-contract-error
   ;; macro
   with-contract
   def/contract))

(in-package :net.phorni.contract)

(define-condition contract-error (error)
  ((expr :reader contract-expr :initarg :expr))
  (:report (lambda (condition stream)
      (format stream
       "~A: ~A"
       (type-of condition)
       (contract-expr condition)))))
(define-condition pre-contract-error (contract-error)
  ())
(define-condition post-contract-error (contract-error)
  ())

;; type-specifierの判別は処理系依存らしい
(defun type-specifier-p (x)
  (or
   #+CCL (ccl:type-specifier-p x)))

(defmacro contract-check (contract-type expr)
  (let ((gsym (gensym)))
    `(let ((,gsym ,expr))
       (if ,gsym
    ,gsym
    (error ,contract-type
    :expr ',expr)))))

(defun parse-contract-body (body)
  (loop
     :for expr in body
     :if (and (listp expr) (eq :pre (car expr)))
     :collect expr into pre
     :else :if (and (listp expr) (eq :post (car expr)))
     :collect expr into post
     :else
     :collect expr into parsed-body
     :finally (return (list pre post parsed-body))))

(defun pre-contract-expand (pre-list)
  `(progn
     ,@(loop
   :for pre in pre-list
   :collect
   `(contract-check 'pre-contract-error ,(second pre)))))

(defun post-contract-expand (vars post-list)
  `(progn
     ,@(loop
   :for post in post-list
   :collect
   `(contract-check 'post-contract-error
      (apply
       (lambda ,(cadr post)
         ,@(cddr post))
       ,vars)))))

(defmacro with-contract (&body body)
  (destructuring-bind
 (pre post parsed-body)
      (parse-contract-body body)
    (let ((gtmp (gensym)))
      `(progn
  ,(pre-contract-expand pre)
  (let ((,gtmp (multiple-value-list (progn ,@parsed-body))))
    ,(post-contract-expand gtmp post)
    (values-list ,gtmp))))))

(defun multiple-value-result-contract-spec? (x)
  (and (listp x)
       (eq :values (car x))
       (every #'type-specifier-p (cdr x))))

(defun check-multiple-value-num (result num)
  (= (length result) num))

(defmacro def/contract ((&rest args-contract) result-contract orig-def)
  (dolist (a args-contract)
    (unless (and (listp a)
   (= (length a) 2)
   (symbolp (first a))
   (type-specifier-p (second a)))
      (error "invalid pre-contract spec: ~A" a)))
  (when (and (not (multiple-value-result-contract-spec? result-contract))
      (type-specifier-p result-contract))
    (setf result-contract (list :values result-contract)))
  (unless (multiple-value-result-contract-spec? result-contract)
    (error "invalid post-contract spec: ~A" result-contract))  
  (let ((def (nth 0 orig-def))
 (name (nth 1 orig-def))
 (args (nth 2 orig-def))
 (body (nthcdr 3 orig-def))
 (gresult (gensym)))
    (multiple-value-bind
   (parsed-body declares doc)
 (alexandria:parse-body body :documentation t)
      `(,def ,name ,args
  ,doc
  ,@declares
  (with-contract
    ,@(loop
  :for a in args-contract
  :collect `(:pre (typep ,(first a) ',(second a))))
    (:post (&rest ,gresult)
    (and (check-multiple-value-num 
   ,gresult
   ,(length (cdr result-contract)))
         (every #'identity 
         (mapcar #'typep 
          ,gresult
          ',(cdr result-contract)))))
    ,@parsed-body)))))

(cl-annot:defannotation contract (args result def) (:arity 3)
  `(def/contract ,args ,result ,def))

;; ex

(def/contract ((n (integer 0 *)) (m (integer 1 *))) number
  (defun my-div-1 (n m)
    (/ n m)))
;; (my-div-1 2 3) => 2/3
;; (my-div-1 -1 1) => PRE-CONTRACT-ERROR: (TYPEP N '(INTEGER 0 *))

(cl-annot:enable-annot-syntax)

@contract ((n (integer 0 *)) (m (integer 1 *))) number
(defun my-div-2 (n m)
  (/ n m))
;; (my-div-2 4 2) => 2
;; (my-div-2 4 0) => PRE-CONTRACT-ERROR: (TYPEP M '(INTEGER 1 *))