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)


;; We make a proper module, so that the bindings in this
;; module can be imported in other modules. It also allows
;; for things like (import (prefix (contract) contract:)),
;; which prefixes all things from this module.
(library (contract)
  (export require
          ensure
          <?>
          and-raise
          ->ensure-expressions
          ensure-expression
          replace-result-placeholder
          ensure-and-wrap
          define-with-contract
          define*-with-contract
          lambda-with-contract
          lambda*-with-contract
          make-contract-violated-exception)
  (import
   (except (rnrs base) let-values)
   (only (guile)
         lambda* λ
         syntax->datum
         syntax-error
         display
         newline
         record-constructor)
   (ice-9 exceptions)
   (srfi srfi-9 gnu)
   (srfi srfi-1)))


;; Define `require` and `ensure`, so that they are available
;; as identifiers. This will cause syntax-rules to be aware
;; of them as identifiers. When the `define-with-contract`
;; macro is used and one writes an expression like (require
;; ...), the identifier `require` is used, instead of it
;; being pure syntax. The advantage is, that the identifier
;; can be renamed, when imported in another module. This
;; enables users to change how macro call looks. They might
;; want to change `ensure` to `make-sure` or
;; `post-condition`, or any other renaming. For example like
;; the following import:

;; (import
;;  (rename (contract)
;;          (require req)
;;          (ensure ens)))

;; Note, that even though `syntax-rules` specifies
;; "literals", specifying <?> still works and still allows
;; for renaming in another module. Very useful!

(define require 'require)
(define ensure 'ensure)
(define <?> '<?>)

;; Create a custom exception type, to make it clearer, that
;; a contract failed, and not only an arbitrary assertion.

(define make-contract-violated-exception
  ;; record-constructor is a procedure, which will return the
  ;; constructor for any record.
  (record-constructor
   ;; Create an exception type, which is a record. This record has a
   ;; constructor, which we can name using define for example.
   (make-exception-type
    ;; name of the new exception type
    '&contract-violated
    ;; parent exception type
    &programming-error
    ;; list of values the constructor of the exception takes and their
    ;; names in the record
    '(message irritants))))


;; `and-raise` needs to be a macro, because its arguments
;; must not be immediately evaluated, otherwise we cannot
;; raise an exception containing the literal expression of
;; the failing check.

;; Usage examples:

;; (list (< amount account-balance) (>= amount 0))
;; (list (integer? result) (positive? result))

;; Ensured expressions, which are arguments to `and-raise`,
;; are already expanded, before `and-raise` is called. For
;; example:

;; (and-raise
;;  (list
;;   (ensure-expression result-identifier (integer? <>))
;;   (ensure-expression result-identifier (positive? <>))))

;; The calls to `ensure-expression` get expanded before
;; `and-raise` is actually called.

(define-syntax and-raise
  (syntax-rules (list)
    ;; `and-raise` takes a list of expressions to check as
    ;; an argument.
    [(_ (list
         (op args* ...)
         ensure-expr* ...))
     (cond
      ;; If the first checked expression is not true, raise
      ;; a contract violated exception.
      [(not (op args* ...))
       (raise-exception
        (make-contract-violated-exception
         "contract violated"
         (quote (op args* ...))))]
      ;; Othewise continue with checking the remaining
      ;; checked expressions.
      [else
       (and-raise (list ensure-expr* ...))])]
    [(_ (list #|nothing|#))
      #t]))


;; `->ensure-expressions` builds up a list of
;; `ensure-expression`s, which contains all the ensured
;; conditions.

;;  (->ensure-expression
;;   result-identifier
;;   (> <?> 10)
;;   (integer? <?>))

;; ->

;;  (list
;;   (ensure-expression result-identifier (> <?> 10))
;;   (ensure-expression result-identifier (integer? <?>)))
(define-syntax ->ensure-expressions
  (syntax-rules (list)
    ;; Final case / Base case: Until all expressions have
    ;; been transformed. Then make a list.
    [(_ result-identifier #|no elements left|#
        (list transformed-expr* ...))
     (list transformed-expr* ...)]

    ;; Intermediate case: Then match the
    ;; ->ensure-expressions call with `ensure-expression`s.
    [(_ result-identifier
        ;; TODO: `...` matches greedy so there is nothing
        ;; left for `expr` and `expr* ...` gets the wrong
        ;; value.
        (op *args ...) ...
        expr
        ;; Now there are already one or more transformed
        ;; expressions.
        (list transformed-expr* ...))
     (->ensure-expressions result-identifier
                           (op *args ...) ...
                           ;; Transform one more expression.
                           (list
                            (ensure-expression result-identifier expr)
                            transformed-expr* ...))]

    ;; Initial case: Begin transforming the expression from
    ;; right to left, from the last element, to the first.
    [(_ result-identifier expr* ... expr)
     (->ensure-expressions result-identifier
                           expr* ...
                           ;; Introduce another artificial
                           ;; level of nesting to avoid
                           ;; "syntax-case: misplaced
                           ;; ellipsis in form ..."
                           ;; error. Multiple ellipsis
                           ;; cannot be at the same level of
                           ;; nesting.
                           (list
                            (ensure-expression result-identifier expr)))]))


;; `ensure-expression` translates a single ensure expression
;; to a condition, in which the placeholder is replaced by
;; the result identifier.
(define-syntax ensure-expression
  (syntax-rules (<?>)
    ;; case for placeholder at the end
    [(_ result-identifier (op args-before* ... <?>))
     (op args-before* ... result-identifier)]
    ;; case for placeholder at the start
    [(_ result-identifier (op <?> args-after* ...))
     (op result-identifier args-after* ...)]
    ;; case for placeholder somewhere in between other
    ;; arguments
    [(_ result-identifier (op args* ...))
     (replace-result-placeholder result-identifier (op args* ...))]))


;; TODO: What if the <?> placeholder is not at the top-level
;; of a check? Might need a replace for arbitrarily nested
;; expressions!

(define-syntax replace-result-placeholder
  (syntax-rules (<?>)
    "Iterates through the arguments of an expression, search for
the placeholder and replace the placeholder with the
result-identifier."
    ;; Solve the trivial case of the placeholder being in
    ;; first place.
    [(_ result-identifier (op <?> expr* ...))
     (op result-identifier expr* ...)]
    ;; If the placeholder is not in first place, then
    ;; introduce a list for arguments, which gets extended,
    ;; to contain all arguments, which are not the
    ;; placeholder.
    [(_ result-identifier (op expr expr* ...))
     (replace-result-placeholder result-identifier (op expr* ...) (list expr))]
    ;; If such a list of previous first arguments already
    ;; exists, we need to match it and extend it.  If the
    ;; placeholder now is in first place, we build the final
    ;; expression.
    [(_ result-identifier (op <?> rest-args* ...) (list prev-args* ...))
     (op prev-args* ... result-identifier rest-args* ...)]
    ;; If the placeholder is still not in first place, then
    ;; put the current first argument in the list of
    ;; previous first arguments.
    [(_ result-identifier (op arg rest-args* ...) (list prev-args* ...))
     (replace-result-placeholder result-identifier
                                     (op rest-args* ...)
                                     (list arg prev-args* ...))]
    ;; Maybe there is no placeholder at all. Catch this case
    ;; as well.
    [(_ result-identifier (op) (list prev-args* ...))
     (op prev-args* ...)]))


;; `ensure-and-wrap` only takes care of wrapping the
;; resulting expression with an `and-raise`.
(define-syntax ensure-and-wrap
  (syntax-rules ()
    [(_ result-identifier expr* ...)
     ;; Wrap with the and-raise and pass on to macro dealing
     ;; with building arguments to and-raise.
     (and-raise
      (->ensure-expressions result-identifier expr* ...))]))


(define-syntax define-with-contract
  (syntax-rules ()
    [(_ function-name
        (require reqs* ...)
        (ensure ensu-expr* ...)
        (lambda (args* ...)
          lambda-body-expr* ...))
     (define function-name
       (lambda-with-contract
        function-name
        (require reqs* ...)
        (ensure ensu-expr* ...)
        (args* ...)
        lambda-body-expr* ...))]))


(define-syntax define*-with-contract
  (syntax-rules ()
    [(_ (function-name args* ...)
        (require reqs* ...)
        (ensure ensu-expr* ...)
        lambda-body-expr* ...)
     (define function-name
       (lambda*-with-contract
        function-name
        (require reqs* ...)
        (ensure ensu-expr* ...)
        (args* ...)
        lambda-body-expr* ...))


;; `lambda-with-contract` is implemented in terms of
;; `lambda*-with-contract`.
(define-syntax lambda-with-contract
  (syntax-rules ()
    ;; CASE 1: A case for when `lambda-with-contract` is
    ;; called without a function name. This should be the
    ;; case, when `lambda-with-contract` is used directly,
    ;; without the indirection through a
    ;; `define-with-contract` call.
    [(_ (require reqs* ...)
        (ensure ensu-expr* ...)
        (args* ...)
        lambda-body-expr* ...)
     (lambda*-with-contract (require reqs* ...)
                            (ensure ensu-expr* ...)
                            (args* ...)
                            lambda-body-expr* ...)]
    ;; CASE 2: A case for a call with an additional function
    ;; name. `lambda-with-contract` should be called with
    ;; function name from a define-with-contract call, but
    ;; not with function name, when used directly.
    [(_ function-name
        (require reqs* ...)
        (ensure ensu-expr* ...)
        (args* ...)
        lambda-body-expr* ...)
     (lambda*-with-contract function-name
                            (require reqs* ...)
                            (ensure ensu-expr* ...)
                            (args* ...)
                            lambda-body-expr* ...)]))


(define-syntax lambda*-with-contract
  (syntax-rules ()
    ;; CASE 1: A case for when `lambda-with-contract` is
    ;; called without a function name. This should be the
    ;; case, when `lambda-with-contract` is used directly,
    ;; without the indirection through a
    ;; `define-with-contract` call.
    [(_ (require reqs* ...)
        (ensure ensu-expr* ...)
        (args* ...)
        lambda-body-expr* ...)
     (lambda* (args* ...)
       ;; temporarily store result of the function
       (let ([result
              (cond
               ;; check pre-conditions (requirements)
               [(not (and-raise (list reqs* ...)))
                (raise-exception
                 (make-exception
                  (make-contract-violated-exception "contract violated"
                                                    (list args* ...))))]
               ;; Run the body of the procedure, to
               ;; calculate the result.
               [else
                lambda-body-expr* ...])])
         (cond
          ;; Check post-conditions (ensures) using the
          ;; result.
          [(not (->ensure-expressions result ensu-expr* ...))
           (raise-exception
            (make-exception
             (make-contract-violated-exception "contract violated"
                                               (list args* ...))))]
          ;; Return result if post-conditions are true.
          [else result])))]
    ;; CASE 2: A case for a call with an additional function
    ;; name. `lambda-with-contract` should be called with
    ;; function name from a define-with-contract call, but
    ;; not with function name, when used directly.
    [(_ function-name
        (require reqs* ...)
        (ensure ensu-expr* ...)
        (args* ...)
        lambda-body-expr* ...)
     (lambda* (args* ...)
       ;; temporarily store result of the function
       (let ([result
              (cond
               ;; check pre-conditions (requirements)
               [(not (and-raise (list reqs* ...)))
                (raise-exception
                 (make-exception
                  (make-contract-violated-exception "contract violated"
                                                    (list args* ...))
                  (make-exception-with-origin (syntax->datum function-name))))]
               ;; Run the body of the procedure, to
               ;; calculate the result.
               [else
                lambda-body-expr* ...])])
         (cond
          ;; Check post-conditions (ensures) using the
          ;; result.
          [(not (->ensure-expressions result ensu-expr* ...))
           (raise-exception
            (make-exception
             (make-contract-violated-exception "contract violated"
                                               (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
  (λ (amount account-balance)
    (- account-balance amount)))


;; Using the defined function just like any other function.

#;(display
 (simple-format
  #f "~a\n" (account-withdraw 10 20)))

#;(display
 (simple-format
  #f "~a\n" (account-withdraw 30 20)))

;; TODO: What does the following code do?

;; (define-syntax require
;;   (identifier-syntax
;;    (syntax-error "'require' can only be used as part of a contract
;; construct")))