guile-project-euler-solutions/lib/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 (lib contract)
  (export require
          ensure
          <?>
          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))


;;; It turns out, that for recursive expansion of macros it
;;; becomes very difficult to write the macro
;;; correctly. However, CK macros promise a solution, by
;;; implementing a way of expanding macros in the same order
;;; as function application works.


;;; Code for the CK macro taken from:
;;; https://okmij.org/ftp/Scheme/macros.html#ck-macros.

;;; Some comments added by me <zelphirkaltstahl@posteo.de>.
;;; Some renaming for readability by me <zelphirkaltstahl@posteo.de>.
;;; Some formatting by me <zelphirkaltstahl@posteo.de>.

  ;; TODO: Explain this thing and why it works :D
  (define-syntax ck
    (syntax-rules (quote)
      ;; This is a base case, which unquotes quoted
      ;; expressions, so that they are evaluated at runtime,
      ;; instead of remaining quoted.
      [(ck () 'v) v]                      ; yield the value on empty stack

      [(ck (((op ...) ea ...) . s) 'v)    ; re-focus on the other argument, ea
       (ck s "arg" (op ... 'v) ea ...)]

      [(ck s "arg" (op va ...))           ; all arguments are evaluated,
       (op s va ...)]                    ; do the redex

      [(ck s "arg" (op ...) 'v ea1 ...)   ; optimization when the first ea
       (ck s "arg" (op ... 'v) ea1 ...)] ; was already a value

      [(ck s "arg" (op ...) ea ea1 ...)   ; focus on ea, to evaluate it
       (ck (((op ...) ea1 ...) . s) ea)]

      [(ck s (op ea ...))                 ; Focus: handle an application;
       (ck s "arg" (op) ea ...)]         ; check if args are values
      ))


  (define-syntax c-cons
    (syntax-rules (quote)
      ;; As mentioned in the explanation on
      ;; https://okmij.org/ftp/Scheme/macros.html#ck-macros:
      ;; All things except the stack are quoted. c-cons
      ;; expects 2 values, head and tail.

      ;; In contrast to the normal pattern matching in
      ;; macros, the parts of a pattern need to be
      ;; quoted. This is probably due to CK macros building
      ;; yet another layer on top of normal macros, managing
      ;; things in a stack and having to avoid things
      ;; getting evaluated (or expanded in case of other,
      ;; possibly non-CK macros) too early.

      ;; For example, macro expansion would evaluate a
      ;; lambda too early, if it appeared without being
      ;; quoted.

      ;; This however, does not stop us from using pattern
      ;; matching on those quoted values! We can still write
      ;; something like the following:

      ;; (c-mymacro stack '(bla blub) 'other)

      ;; And then use the parts in the resulting expression
      ;; as we want, but again quote the resulting
      ;; expression.
      [(c-cons stack 'head 'tail)
       ;; Build up a pair. Always pass the stack along to
       ;; the CK macro.
       (ck stack '(head . tail))]))


  ;; c-map allows to map any kind of expression to a list of
  ;; expressions.
  (define-syntax c-map
    (syntax-rules (quote)
      ;; If the applied-thing is applied to the empty list,
      ;; then there is no need to even look at what the
      ;; applied-thing consists of or to destructure it via
      ;; pattern matching, because anything applied to the
      ;; empty list, will be the empty list.
      [(c-map stack
              'applied-thing
              '())
       ;; Simply return the empty list.
       (ck stack
           ;; Base case gives the empty list, to build a
           ;; proper list.
           '())]
      ;; If however there are list elements, at least a head
      ;; and some arbitrary tail, then it becomes necessary
      ;; to take the applied thing apart, so that we can put
      ;; the first element of the list into the expression
      ;; of the applied-thing, thereby applying
      ;; applied-thing to the first element.
      [(c-map stack
              '(applied-thing ...)
              '(head . tail))
       (ck stack
           ;; Build up a list using cons.
           (c-cons
            ;; Apply the applied-thing to the first element.
            (applied-thing ... 'head)
            ;; Recursively expand c-map for the tail of the
            ;; list of expressions.
            (c-map '(applied-thing ...) 'tail)))]))


  ;; Example usage:

  ;; (ck ()
  ;;     (c-map '(c-cons '10)
  ;;            '((1) (2))))

  ;; (ck ()
  ;;     (c-map '(c-cons '+)
  ;;            '((1) (2))))


  (define-syntax c-apply
    (syntax-rules (quote)
      [(c-apply stack 'proc '(expr* ...))
       (ck stack '(proc expr* ...))]))

  ;; Example usage:

  ;; (ck ()
  ;;     (c-apply '+
  ;;              (c-map '(c-cons '+)
  ;;                     '((1) (2)))))


  ;; To quote things, we need to simply wrap with another
  ;; quote. This makes sense, because in the base case of
  ;; the CK-macro 1 quote wrapping is removed:

  ;; [(ck () 'v) v]

  ;; (see above).
  (define-syntax c-quote
    (syntax-rules (quote)
      [(c-quote s 'x)
       (ck s ''x)]))


;;; When we use the CK macro above, there are a few rules to
;;; adhere to, to make it all work:

;;; 1. A macro CK style macro must always expand into a call
;;; of the `ck` macro.

;;; 2. When expanding into the `ck` macro, never forget to
;;; pass the stack.

;;; 3. All values after the stack must be quoted, except
;;; when they are CK style macros themselves.

;;; 4. When A CK style macro expands into other CK style
;;; macros, their arguments still need to be quoted.

;;; 5. To start the expansion process, call a macro with the
;;; form (ck () macro-call).

;;; 6. The `ck` macro will always add the stack as an
;;; "argument", when expanding into a CK style macro. This
;;; means one must always match the stack, even though the
;;; call to a macro does not contain the stack.


  ;; 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 origin irritants))))


  ;; `c-and-raise` needs to be a macro, because its
  ;; arguments must not be evaluated, before we can look at
  ;; them and build up an expression, which contains the
  ;; argument in its unevaluated form. We need the not yet
  ;; evaluated form, to have a readable and understandable
  ;; error message, when raising an exception. The exception
  ;; will contain the literal expression, which failed to
  ;; evaluate to a truthy value.

  (define-syntax c-and-raise
    (syntax-rules (quote)
      ;; `and-raise` takes a list of expressions to check as
      ;; an argument.
      [(c-and-raise stack
                    'function-name
                    '(list
                      (op args* ...)
                      expr* ...))
       (ck stack
           '(cond
             [(op args* ...)
              (ck stack
                  (c-and-raise (quote function-name)
                               (quote (list expr* ...))))]
             [else
              (raise-exception
               (make-contract-violated-exception
                "contract violated"
                (quote function-name)
                (quote (op args* ...))))]))]
      [(c-and-raise stack
                    (quote function-name)
                    (quote (list #|nothing|#)))
       (ck stack (quote #t))]))


  ;; Usage example:

  ;; (ck ()
  ;;     (c-and-raise 'unknown-origin '(list (= 1 1) (= 2 3))))

  ;; (define result 3)
  ;; (ck ()
  ;;     (c-and-raise
  ;;      'unknown-origin
  ;;      (c-map '(c-replace-placeholder 'result)
  ;;             '(list (= 1 <?>) (= 2 3)))))

  ;; (define result 3)
  ;; (ck ()
  ;;     (c-and-raise
  ;;      'my-function-name
  ;;      (c-map '(c-replace-placeholder 'result)
  ;;             '(list (= 1 <?>) (= 2 3)))))


  (define-syntax c-replace-placeholder
    (syntax-rules (quote <?>)
      ;; Replace the placeholder, if it is the expression.
      [(c-replace-placeholder stack 'result (quote <?>))
       (ck stack (quote result))]

      ;; Only one expression remaining.
      [(c-replace-placeholder stack 'result '(expr))
       (ck stack
           (c-cons
            (c-replace-placeholder 'result 'expr)
            '()))]

      ;; There are multiple expressions left. (Case of single
      ;; expression is matched earlier.)
      [(c-replace-placeholder stack 'result '(expr expr* ...))
       (ck stack
           (c-cons
            (c-replace-placeholder 'result 'expr)
            (c-replace-placeholder 'result '(expr* ...))))]

      ;; Take care of vectors.
      [(c-replace-placeholder stack 'result (quote #(expr* ...)))
       (ck stack
           (c-list->vector
            (c-replace-placeholder 'result
                                   (c-vector->list
                                    '#(expr* ...)))))]

      ;; Or a non-compound expression, which is not the
      ;; placeholder.
      [(c-replace-placeholder stack 'result 'expr)
       (ck stack 'expr)]
      ))


  ;; Example usage:

  ;; (ck () (c-replace-placeholder 'result ''(1 2 <>)))

  ;; (ck ()
  ;;     (c-replace-placeholder 'result
  ;;                            '(apply + (list 1 2 <?>))))

  ;; (ck ()
  ;;     (c-map '(c-replace-placeholder 'result)
  ;;            '((= 1 <?>))))


  (define-syntax c-list->vector
    (syntax-rules (quote list)
      [(_ stack (quote '(expr* ...)))
       ;; Replace with call to (vector ...), because #()
       ;; syntax does not evaluate the things inside
       ;; parentheses. If there was a reference to a
       ;; variable in there, it would be seen as a symbol
       ;; only. The actual value would not be in there.
       (ck stack (quote (vector expr* ...)))]
      [(_ stack (quote (list expr* ...)))
       (ck stack (quote (vector expr* ...)))]
      ;; Fallback for better error message.
      [(_ stack (quote other* ...))
       (syntax-error
        "could not recognize list in expression"
        other* ...)]))


  ;; Example usage:

  ;; (ck ()
  ;;     (c-list->vector ''(a b c)))

  ;; (ck ()
  ;;     (c-list->vector '(list 1 2 3)))


  (define-syntax c-vector->list
    (syntax-rules (quote list)
      [(_ stack (quote #(expr* ...)))
       (ck stack (quote '(expr* ...)))]
      [(_ stack (quote (vector expr* ...)))
       (ck stack (quote (list expr* ...)))]
      ;; Fallback for better error message.
      [(_ stack (quote other* ...))
       (syntax-error
        "could not recognize vector in expression"
        other* ...)]))


  (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* ...))]
      [(_ (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* ...))]))


  ;; Example usage:

  ;; (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)))

  ;; (define-with-contract (account-withdraw
  ;;                        amount
  ;;                        account-balance
  ;;                        add-withdraw-amount
  ;;                        add-add-withdraw-amount)
  ;;   (require (<= amount account-balance)
  ;;            (>= amount 0))
  ;;   (ensure (>= <> 0))
  ;;   (- account-balance
  ;;      (+ amount
  ;;         add-withdraw-amount
  ;;         add-add-withdraw-amount)))


  (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* ...))]))


  ;; Example usage:

  ;; (define*-with-contract (account-withdraw
  ;;                         amount
  ;;                         account-balance
  ;;                         #:optional (add-withdraw-amount 0)
  ;;                         #:key (add-add-withdraw-amount 0))
  ;;   (require (<= amount account-balance)
  ;;            (>= amount 0))
  ;;   (ensure (>= <> 0))
  ;;   (- account-balance
  ;;      (+ amount
  ;;         add-withdraw-amount
  ;;         add-add-withdraw-amount)))


  ;; `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* ...)]))


  ;; Example usage:

  ;; ((lambda-with-contract
  ;;   (require (> a 0))
  ;;   (ensure (> ((λ (res) (+ res 1)) <>) 0))
  ;;   (a b)
  ;;   (+ a b)) 1 -1)


  ;; `lambda*-with-contract` is the macro, which is the
  ;; entrypoint to calling CK macros. It is also used for
  ;; implementing `lambda-with-contract`,
  ;; `define-with-contract` and `define*-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* (args* ...)
         ;; temporarily store result of the function
         (let ([result
                (cond
                 ;; check pre-conditions (requirements)
                 [(not (ck ()
                           (c-and-raise
                            'unknown-origin
                            (c-map '(c-replace-placeholder 'result)
                                   '(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 (ck ()
                      (c-and-raise
                       'unknown-origin
                       (c-map '(c-replace-placeholder 'result)
                              '(list 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 (ck ()
                           (c-and-raise
                            (quote function-name)
                            (c-map '(c-replace-placeholder 'result)
                                   '(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 (ck ()
                      (c-and-raise
                       (quote function-name)
                       (c-map '(c-replace-placeholder 'result)
                              '(list 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])))]))


  ;; Example usage:

  ;; ((lambda*-with-contract
  ;;   (require (> a 0))
  ;;   (ensure (> ((λ (res) (+ res 1)) <>) 0))
  ;;   (a #:optional (b 0) #:key (c 0))
  ;;   (+ a b)) 1 0 #:c -1)

  ;; 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).

  ;; Simple 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)))

  ;; More complex usage example:

  #;(define-with-contract account-withdraw
    (require (<= amount account-balance)
             (>= amount (vector-ref #(0) 0)))
    (ensure (>= ((lambda (a) (vector-ref #(<>) 0)) <>) 0))  ; depends on what the function returns
    (λ (amount account-balance)
      (- account-balance amount)))
  )