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 (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 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
                  '(list
                    (op args* ...)
                    expr* ...))
     (ck stack
         '(cond
           [(op args* ...)
            (ck stack (c-and-raise (quote (list expr* ...))))]
           [else
            (raise-exception
             (make-contract-violated-exception
              "contract violated"
              (quote (op args* ...))))]))]
    [(c-and-raise stack (quote (list #|nothing|#)))
     (ck stack (quote #t))]))


;; Usage example:

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

;; (define result 3)
;; (ck ()
;;     (c-and-raise
;;      (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* ...)))))
     #;(ck ()
         ;; Convert back to a vector.
         (c-list->vector
          ;; Apply the replacing.
          (c-replace-placeholder
           'result
           ;; Transform into a list so that the normal
           ;; replacing works.
           (c-vector->list '#(1 2 <>)))))]

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