guile-examples/shell/guile-shell/contracts/ck-extra.scm

;; This library makes use of the CK macro base library, to
;; define more CK style macros.

(library (ck-extra)
  (export c-and-raise
          c-replace-placeholder
          c-list->vector
          c-vector->list
          <?>)
  (import (except (rnrs base) let-values)
          (only (guile)
                lambda* lambda λ
                raise-exception)
          (ck-base)
          (exceptions))

  (define <?> '<?>)

  ;; ==========================
  ;; additional CK style macros
  ;; ==========================

  ;; `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
             ;; Check the first condition.
             [(op args* ...)
              (ck stack
                  ;; Check the rest of the conditions.
                  (c-and-raise (quote function-name)
                               (quote (list expr* ...))))]
             [else
              (raise-exception
               (make-exception-contract-violated-compound
                "contract violated"
                (quote function-name)
                (quote (op args* ...))
                (list (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* ...)])))