guile-library 0.2.2-0.2 / usr / share / guile / site / apicheck.scm

;; (apicheck) -- check for API incompatibilities
;; Copyright (C) 2007, 2013  Andy Wingo <wingo at pobox dot com>

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; @code{(apicheck)} exports two routines. @code{apicheck-generate}
;; produces a description of the Scheme API exported by a set of modules
;; as an S-expression. @code{apicheck-validate} verifies that the API
;; exported by a set of modules is compatible with an API description
;; generated by @code{apicheck-generate}.
;;
;; It would be nice to have Makefile.am fragments here, but for now, see
;; the Guile-Library source distribution for information on how to
;; integrate apicheck with your module's unit test suite.
;;
;;; Code:

(define-module (apicheck)
  #:use-module (unit-test)
  #:use-module (oop goops)
  #:use-module (ice-9 pretty-print)
  #:use-module ((ice-9 common-list) #:select (uniq))
  #:use-module ((srfi srfi-1) #:select (append-map
                                        lset-difference))

  #:export (apicheck-generate apicheck-validate))

(define *path* (make-fluid))
(fluid-set! *path* '())

(define-macro (with-path k v body)
  `(with-fluids ((*path* (acons ,k ,v (fluid-ref *path*))))
     ,body))

(define (write-current-path port)
  (for-each (lambda (p)
              (format port "In ~a ~a:\n" (car p) (cdr p)))
            (fluid-ref *path*)))

(define (fail message . args)
  (write-current-path (current-error-port))
  (display message (current-error-port))
  (for-each (lambda (x)
              (display #\space (current-error-port))
              (write x (current-error-port)))
            args)
  (newline (current-error-port))
  (error "API changed incompatibly")
  (apply error message args))

(define (interface module)
  (case (module-kind module)
    ((interface) module)
    (else
     (fail "Invalid API: imported module ~a not an interface" module))))

(define (module-all-uses module)
  (let ((direct (module-uses module)))
    (map interface
         (append direct
                 (apply append (map module-all-uses direct))))))

(define (module-exports module)
  (module-map (lambda (k v) k) module))

(define (symbolcomp pred)
  (lambda (a b)
    (pred (symbol->string a) (symbol->string b))))

(define symbol<?
  (symbolcomp string<?))

(define symbol>?
  (symbolcomp string>?))

(define (symlist<? a b)
  (cond
   ((null? a) (not (null? b)))
   ((null? b) #f)
   ((symbol? a) (or (pair? b) (symbol<? a b)))
   ((symbol? b) #f)
   ((symbol<? (car a) (car b)) #t)
   ((symbol>? (car a) (car b)) #f)
   (else (symlist<? (cdr a) (cdr b)))))

(define (module<? a b)
  (symlist<? (module-name a) (module-name b)))

(define (all-public-interfaces module-names)
  (uniq
   (sort
    (append-map
     (lambda (name)
       (let ((mod (resolve-interface name)))
         (cons mod (module-all-uses mod))))
     module-names)
    module<?)))

(define (module-exports-sorted mod)
  (sort (hash-fold (lambda (k v rest) (cons k rest)) '()
                   (module-obarray mod))
        symbol<?))

(define (module-map-sorted proc mod)
  (let ((obarray (module-obarray mod)))
    (map (lambda (sym)
           (proc sym (hashq-ref obarray sym)))
         (module-exports-sorted mod))))

(define (procedure-arity proc)
  (cond-expand
   (guile-2
    (cons 'arity (procedure-minimum-arity proc)))
   (else
    (assq 'arity (procedure-properties proc)))))

;; deals with improper lists
(define (map* proc l)
  (cond ((null? l) '())
        ((pair? l) (cons (proc (car l)) (map* proc (cdr l))))
        (else (proc l))))

(define (method-specializer-names method)
  (map* class-name (method-specializers method)))

(define (variable-type sym var)
  (let ((val (catch #t
                    (lambda () (variable-ref var))
                    (lambda args (fail "unbound variable" sym)))))
    (cond
     ((is-a? val <class>) (list 'class))
     ((is-a? val <generic>) (cons 'generic
                                  (sort
                                   (map
                                    method-specializer-names
                                    (generic-function-methods val))
                                   symlist<?)))
     ((procedure? val) (list 'procedure (procedure-arity val)))
     ((macro? val) (list 'macro))
     ((struct-vtable? val) (list 'struct-vtable))
     (else (list (class-name (class-of val)))))))

(define (module-api module)
  `(,(module-name module)
    (uses-interfaces
     ,@(map module-name (sort (module-uses module) module<?)))
    (typed-exports
     ,@(module-map-sorted
        (lambda (sym var)
          (cons sym (variable-type sym var)))
        module))))

(define *apicheck-major-version* 1)
(define *apicheck-minor-version* 0)

(define (apicheck-generate module-names)
  "Generate a description of the API exported by the set of modules
@var{module-names}."
  (cons*
   'module-api
   (list 'version *apicheck-major-version* *apicheck-minor-version*)
   (map module-api
        (all-public-interfaces module-names))))

(define (form-match? form template)
  (define (pred? x)
    (procedure? x))
  (define (var? x)
    (eq? x '_))
  (define (atom? x)
    (not (pair? x)))
  (define (pred-match? pred form)
    (pred form))
  (define (var-match? var form)
    #t)
  (define (atom-match? atom form)
    (eq? atom form))
  (cond ((null? template) (null? form))
        ((pred? template) (pred-match? template form))
        ((var? template) (var-match? template form))
        ((atom? form) (atom-match? template form))
        (else (and (form-match? (car form) (car template))
                   (form-match? (cdr form) (cdr template))))))

(define (apicheck-form? form)
  (form-match? form `(module-api
                      (version ,number? ,number?)
                      . _)))

(define (apicheck-version-compatible? form)
  (let ((version-form (cadr form)))
    (and (= (cadr version-form) *apicheck-major-version*)
         (<= (caddr version-form) *apicheck-minor-version*))))

(define (assert-sets-compatible! expected actual)
  (let ((new (lset-difference equal? actual expected)))
    (if (not (null? new))
        (warn "New API, update your API form" new)))
  (let ((missing (lset-difference equal? expected actual)))
    (if (not (null? missing))
        (fail "Public API has been removed" missing))))

(define (arities-compatible? old new)
  ;; arity := (arity nrequired noptional rest?)
  (define (required x)
    (cadr x))
  (define (optional x)
    (caddr x))
  (define (rest? x)
    (cadddr x))
  (and (cond ((< (required old) (required new)) #f)
             ((= (required old) (required new)) #t)
             (else (or (rest? new)
                       (<= (- (required old) (required new))
                           (- (optional new) (optional old))))))
       (or (<= (required old) (required new))
           (rest? new))
       (if (rest? old) (rest? new) #t)))

(define (method-specializers-compatible? old new)
  ;; FIXME: define better
  (assert-sets-compatible! old new))

(define (apicheck-validate-var-type type-form var)
  (let ((name (car type-form))
        (expected-type (cadr type-form))
        (expected-args (cddr type-form)))
    (let ((actual (variable-type name var)))
      (let ((actual-type (car actual))
            (actual-args (cdr actual)))
        (or (eq? expected-type actual-type)
            (fail "API break: export changed type"
                   name expected-type actual-type))
        (or (case expected-type
              ((generic)
               (pk name expected-args actual-args)
               (method-specializers-compatible? expected-args actual-args))
              ((procedure)
               (arities-compatible? (car expected-args) (car actual-args)))
              (else ;; pass
               #t))
            (fail "API break: export changed type incompatibly"
                   type-form actual))))))

(define (apicheck-validate-module module-form)
  (with-path "module" (car module-form)
    (let ((interface (resolve-interface (car module-form)))
          (uses-interfaces (cdr (assq 'uses-interfaces module-form)))
          (typed-exports (cdr (assq 'typed-exports module-form))))
      (with-path "re-exported interfaces" uses-interfaces
        (assert-sets-compatible!
         uses-interfaces
         (map module-name (module-uses interface))))
      (with-path "exports" (map car typed-exports)
        (assert-sets-compatible!
         (map car typed-exports)
         (module-exports-sorted interface)))
      (for-each
       (lambda (form)
         (with-path "exported binding" (car form)
           (apicheck-validate-var-type
            form
            (module-local-variable interface (car form)))))
       typed-exports))))

(define (apicheck-validate api module-names)
  "Validate that the API exported by the set of modules
@var{module-names} is compatible with the recorded API description
@var{api}. Raises an exception if the interface is incompatible."
  (or (apicheck-form? api)
      (error "Invalid apicheck form" api))
  (or (apicheck-version-compatible? api)
      (error "Invalid apicheck version"
             *apicheck-major-version* *apicheck-minor-version* api))

  (let ((module-forms (cddr api)))
    (with-path "toplevel exports" (map car module-forms)
     (assert-sets-compatible!
      (map car module-forms)
      (map module-name (all-public-interfaces module-names))))
    (for-each apicheck-validate-module module-forms)))