guile-examples/macros/contract.scm

;; Suppose we wanted to check assumptions about arguments to
;; our function. What kind of form could we write to express
;; this?

;; (define-with-contract account-withdraw
;;   (requires (< amount account-balance))
;;   (ensures (>= account-balance 0))
;;   (lambda (amount account-balance)
;;     ...))

;; Or abstractly:

;; (define-with-contract func
;;   (requires req-pred* ...)
;;   (ensures ensure-pred* ...)
;;   lambda-expr)


(import
 (except (rnrs base) let-values)
 (only (guile)
       lambda* λ)
 (ice-9 exceptions)
 (srfi srfi-1))


;; and-raise needs to be a macro, because its arguments must
;; not be immediately evaluated, otherwise we cannot raise
;; an exception containing the failing check.
(define-syntax and-raise
  (syntax-rules ()
    [(_ (op args* ...) check-expr* ...)
     (cond
      [(not (op args* ...))
       (raise-exception
        (make-exception
         (make-assertion-failure)
         (make-exception-with-message "assertion failed")
         (make-exception-with-irritants (quote (op args* ...)))))]
      [else
       (and-raise check-expr* ...)])]
    [(_ #|nothing|#)
      #t]))


;; `ensure` builds up an `and` expression, which contains
;; all the conditions.
(define-syntax ensure-with-result
  (syntax-rules (ensure)
    [(_ identifier expr* ... (op args* ...))
     (and-raise
      ;; insert identifier on the left
      (op identifier args* ...)
      (ensure-with-result identifier expr* ...))]
    ;; If there is only one more ensure clause, transform
    ;; it, and do not place another macro call.
    [(_ identifier (op args* ...))
     ;; insert identifier on the left
     (op identifier args* ...)]
    ;; If there are no more ensure clauses, transform to
    ;; `#t`, the neutral element of `and`.
    [(_ identifier)
     #t]))


(define-syntax define-with-contract
  (syntax-rules (require ensure <?>)
    ;; first process ensure (post-conditions)
    [(_ function-name
        (require reqs* ...)
        (ensure ensu-expr* ...)
        (lambda (args* ...)
          lambda-body-expr* ...))
     (define function-name
       (lambda (args* ...)
         ;; temporarily store result of the function
         (let ([result
                (cond
                 ;; check pre-conditions (requirements)
                 [(not (and-raise reqs* ...))
                  (raise-exception
                   (make-exception
                    (make-assertion-failure)
                    (make-exception-with-message "assertion failed")
                    (make-exception-with-irritants (list args* ...))
                    (make-exception-with-origin (syntax->datum function-name))))]
                 ;; otherwise run the body
                 [else
                  lambda-body-expr* ...])])
           (cond
            ;; check post-conditions (ensures)
            [(not (ensure-with-result result ensu-expr* ...))
             ;; Problem: Cannot know which post-condition
             ;; failed. Could be improved.
             (raise-exception
              (make-exception
               (make-assertion-failure)
               (make-exception-with-message "assertion failed")
               (make-exception-with-irritants (list args* ...))
               (make-exception-with-origin (syntax->datum function-name))))]
            ;; return result if post conditions are true
            [else result]))))]))


;; Lets make an example definition: Withdrawing an amount of
;; money from an account, returning the new account balance
;; (although not really mutating the account or anything,
;; really just a toy example).
(define-with-contract account-withdraw
  (require (< amount account-balance)
           (>= amount 0))
  (ensure (>= 0))  ; depends on what the function returns
  (lambda (amount account-balance)
    (- account-balance amount)))


;; Using the defined function just like any other function.
(display (account-withdraw 10 20)) (newline)
(display (account-withdraw 30 20)) (newline)