guile-examples/shell/guile-shell/contracts/test.scm

(import (except (rnrs base) let-values map)
        (rnrs exceptions (6))
        (only (guile)
              lambda* λ
              string=?)
        (ice-9 exceptions)
        (srfi srfi-1)  ; list utils
        (srfi srfi-64)  ; unit testing
        (srfi srfi-43)  ; vectors
        ;; modules under test
        (ck-base)
        (rename (ck-extra) (<?> <?>))
        (contract)
        (exceptions))


(test-begin "test")

(test-group "ck-base"

  (test-equal "c-cons conses a number onto every sublist"
    '((10 1) (10 2))
    (ck ()
        (c-quote
         (c-map '(c-cons '10)
                '((1) (2))))))

  (test-equal "c-cons conses a + onto every sublist"
    '((+ 1) (+ 2))
    (ck ()
        (c-quote
         (c-map '(c-cons '+)
                '((1) (2))))))

  (test-eqv "c-cons conses a function onto a list to make a function call"
    3
    (ck () (c-cons '+ '(1 2))))

  (test-equal "c-map maps to all elements of a list - 1"
    '((10 1) (10 2))
    (ck ()
        (c-quote
         (c-map '(c-cons '10)
                '((1) (2))))))

  (test-equal "c-map maps to all elements of a list - 2"
    '((+ 1) (+ 2))
    (ck ()
        (c-quote
         (c-map '(c-cons '+)
                '((1) (2))))))

  (test-equal "c-map maps to all elements of a list - 3"
    '(((lambda (elem) (+ elem 1)) 1)
      ((lambda (elem) (+ elem 1)) 2))
    (ck ()
        (c-quote
         (c-map
          ;; cons an immediately applied function
          '(c-cons '(lambda (elem) (+ elem 1)))
          '((1) (2))))))

  (test-equal "c-apply applies procedure to list of arguments - 1"
    5
    (ck ()
        (c-apply '+
                 (c-map '(c-cons '(lambda (elem) (+ elem 1)))
                        '((1) (2))))))

  (test-equal "c-apply applies procedure to list of arguments - 2"
    6
    (let ([result 3])
      (ck ()
          (c-replace-placeholder 'result
                                 '(apply + (list 1 2 <?>))))))

  (test-equal "c-quote quotes things"
    '((anything 1) (anything 2))
    (ck ()
        (c-quote
         (c-map '(c-cons 'anything)
                '((1) (2))))))

  (test-equal "c-unquote unquotes things"
    'x
    (ck () (c-unquote ''x))))

(test-group "ck-extra"

  ;; Cannot use test-error here, because test-error has a
  ;; bug, which causes the test to pass, even if the wrong
  ;; exception is raised.
  (test-assert "c-and-raise raises a contract violation for a trivial case."
    (guard (exn
            [(and (contract-violated-exception? exn)
                  (exception-with-message? exn)
                  (exception-with-origin? exn)
                  (string=? (exception-origin exn)
                            "unknown origin")
                  (exception-with-irritants? exn))
             #t])
      (ck ()
          (c-and-raise
           (quote "unknown origin")
           (quote (list (= 1 1)
                        ;; Here something wrong ...
                        (= 2 3)))))))

  (test-assert "c-and-raise does not raise an exception when all expressions are true."
    (ck ()
        (c-and-raise
         (quote "unknown origin")
         (quote (list (= 1 1))))))

  (test-eqv "c-replace-placeholder replaces the placeholder in a simple expression"
    6
    (let ([result 3])
      (ck ()
          (c-replace-placeholder
           (quote result)
           (quote (+ 1 2 <?>))))))

  (test-equal "c-replace-placeholder replaces the placeholder in a list"
    '(1 2 3)
    (let ([result 3])
      (ck ()
          (c-replace-placeholder
           (quote result)
           (quote (list 1 2 <?>))))))

  (test-equal "c-replace-placeholder replaces the placeholder in a compound expression"
    '(1 2 3)
    (let ([result 7])
      (ck ()
          (c-replace-placeholder
           (quote result)
           (quote
            (list 1
                  2
                  (vector-index (λ (elem) (= elem <?>))
                                (vector 4 5 6 7 8))))))))

  (test-equal "c-replace-placeholder replaces the placeholder multiple times in a compound expression"
    '(1 2 7 3)
    (let ([result 7])
      (ck ()
          (c-replace-placeholder
           (quote result)
           (quote
            (list 1
                  2
                  <?>
                  (vector-index (λ (elem) (= elem <?>))
                                (vector 4 5 6 7 8))))))))

  (test-equal "c-list->vector converts a list to a vector - 1"
    (vector 1 2 3)
    (ck ()
        (c-list->vector '(list 1 2 3))))

  (test-equal "c-list->vector converts a list to a vector - 2"
    (vector 1 2 3)
    (ck ()
        (c-list->vector ''(1 2 3))))

  (test-equal "c-vector->list converts a vector to a list - 1"
    (list 1 2 3)
    (ck ()
        (c-vector->list '(vector 1 2 3))))

  (test-equal "c-vector->list converts a vector to a list - 2"
    (list 1 2 3)
    (ck ()
        (c-vector->list '#(1 2 3)))))


(test-group "contract"
  (test-group "lambda*-with-contract"
    (test-equal "lambda*-with-contract - contract does not raise an exception when not violated"
      "00234"
      ((lambda*-with-contract
        (require (integer? num)
                 (char? padding-char)
                 (integer? padding-length)
                 (or (positive? padding-length)
                     (zero? padding-length)))
        (ensure (string? <?>)
                (>= (string-length <?>) padding-length))
        (num padding-char padding-length)
        (let* ([num-as-str (number->string num)]
               [len-diff (- padding-length
                            (string-length num-as-str))])
          (cond
           [(positive? len-diff)
            (call-with-output-string
              (λ (port)
                (let iter ([counter 0])
                  (cond
                   [(< counter len-diff)
                    (display padding-char port)
                    (iter (+ counter 1))]
                   [else
                    (display num-as-str port)]))))]
           [else num-as-str]))) 234 #\0 5))

    (test-assert "lambda*-with-contract - raises when requirement violated"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (string=? (exception-origin exn)
                              "unknown origin")
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(integer? num)
                            (exception-irritants exn)))
               #t])
        ((lambda*-with-contract
          (require (integer? num)
                   (char? padding-char)
                   (integer? padding-length)
                   (or (positive? padding-length)
                       (zero? padding-length)))
          (ensure (string? <?>)
                  (>= (string-length <?>) padding-length))
          (num padding-char padding-length)
          (let* ([num-as-str (number->string num)]
                 [len-diff (- padding-length
                              (string-length num-as-str))])
            (cond
             [(positive? len-diff)
              (call-with-output-string
                (λ (port)
                  (let iter ([counter 0])
                    (cond
                     [(< counter len-diff)
                      (display padding-char port)
                      (iter (+ counter 1))]
                     [else
                      (display num-as-str port)]))))]
             [else num-as-str]))) "234" #\0 5)))

    (test-assert "lambda*-with-contract - raises when ensure violated"
      (guard (exn [(and (contract-violated-exception? exn)
                        ;; check message
                        (exception-with-message? exn)
                        (string=? (exception-message exn)
                                  "contract violated")
                        ;; check origin
                        (exception-with-origin? exn)
                        (string=? (exception-origin exn)
                                  "unknown origin")
                        ;; check irritants
                        (exception-with-irritants? exn)
                        (equal? '(>= (string-length result)
                                     padding-length)
                                (exception-irritants exn)))
                   #t])
        ((lambda*-with-contract
          (require (integer? num)
                   (char? padding-char)
                   (integer? padding-length)
                   (or (positive? padding-length)
                       (zero? padding-length)))
          (ensure (string? <?>)
                  (>= (string-length <?>) padding-length))
          (num padding-char padding-length)
          (let* ([num-as-str (number->string num)]
                 [len-diff (- padding-length
                              (string-length num-as-str))])
            (cond
             [(positive? len-diff)
              (call-with-output-string
                (λ (port)
                  (let iter ([counter 0])
                    ;; Making a mistake here by using <=
                    ;; instead of <, in order to fail the
                    ;; ensure.
                    (when (<= counter len-diff)
                      (display padding-char port)
                      (iter (+ counter 1)))
                    (display num-as-str port))))]
             [else num-as-str]))) 234 #\0 5)))

    (test-assert "lambda*-with-contract - works with optional args"
      (guard (exn [(and (contract-violated-exception? exn)
                        ;; check message
                        (exception-with-message? exn)
                        (string=? (exception-message exn)
                                  "contract violated")
                        ;; check origin
                        (exception-with-origin? exn)
                        (string=? (exception-origin exn)
                                  "unknown origin")
                        ;; check irritants
                        (exception-with-irritants? exn)
                        (equal? '(char? padding-char)
                                (exception-irritants exn)))
                   #t])
        ((lambda*-with-contract
          (require (integer? num)
                   (char? padding-char)
                   (integer? padding-length)
                   (or (positive? padding-length)
                       (zero? padding-length)))
          (ensure (string? <?>)
                  (>= (string-length <?>) padding-length))
          (num padding-length #:optional (padding-char #\0))
          (let* ([num-as-str (number->string num)]
                 [len-diff (- padding-length
                              (string-length num-as-str))])
            (cond
             [(positive? len-diff)
              (call-with-output-string
                (λ (port)
                  (let iter ([counter 0])
                    (when (< counter len-diff)
                      (display padding-char port)
                      (iter (+ counter 1)))
                    (display num-as-str port))))]
             [else num-as-str]))) 234 5 "9")))

    (test-assert "lambda*-with-contract - works with keyword args"
      (guard (exn [(and (contract-violated-exception? exn)
                        ;; check message
                        (exception-with-message? exn)
                        (string=? (exception-message exn)
                                  "contract violated")
                        ;; check origin
                        (exception-with-origin? exn)
                        (string=? (exception-origin exn)
                                  "unknown origin")
                        ;; check irritants
                        (exception-with-irritants? exn)
                        (equal? '(char? padding-char)
                                (exception-irritants exn)))
                   #t])
        ((lambda*-with-contract
          (require (integer? num)
                   (char? padding-char)
                   (integer? padding-length)
                   (or (positive? padding-length)
                       (zero? padding-length)))
          (ensure (string? <?>)
                  (>= (string-length <?>) padding-length))
          (num padding-length #:key (padding-char #\0))
          (let* ([num-as-str (number->string num)]
                 [len-diff (- padding-length
                              (string-length num-as-str))])
            (cond
             [(positive? len-diff)
              (call-with-output-string
                (λ (port)
                  (let iter ([counter 0])
                    (when (< counter len-diff)
                      (display padding-char port)
                      (iter (+ counter 1)))
                    (display num-as-str port))))]
             [else num-as-str]))) 234 5 #:padding-char "9"))))

  (test-group "lambda-with-contract"
    (test-eqv "lambda-with-contract - contract does not raise an exception when not violated"
      7
      ((lambda-with-contract
        (require
         ;; The amount withdrawn needs to be less or equal to
         ;; the amount on the account.
         (<= amount account-balance)
         ;; The amount withdrawn needs to be greater or equal
         ;; to zero.
         (>= amount 0))
        (ensure
         ;; Make sure, that the amount on the account after
         ;; withdrawing an amount is greater or equal to
         ;; zero.
         (>= <?> 0))
        (amount account-balance)
        (- account-balance amount))
       ;; Try to withdraw 5 from the account.
       5
       ;; The account has 12.
       12))

    (test-assert "lambda-with-contract - simple number contract works"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (string=? (exception-origin exn)
                              "unknown origin")
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(<= amount account-balance)
                            (exception-irritants exn)))
               #t])
        ((lambda-with-contract
          (require (<= amount account-balance)
                   (>= amount 0))
          (ensure (>= <?> 0))
          (amount account-balance)
          (- account-balance amount)) 100 90)))

    (test-assert "lambda-with-contract - simple number contract works with negative numbers"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (string=? (exception-origin exn)
                              "unknown origin")
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(>= amount 0)
                            (exception-irritants exn)))
               #t])
        ((lambda-with-contract
          (require (<= amount account-balance)
                   (>= amount 0))
          (ensure (>= <?> 0))
          (amount account-balance)
          (- account-balance amount)) -15 -10))))

  (test-group "define-with-contract"
    (test-eqv "define-with-contract - does not raise an exception when not violated"
      7
      (begin
        (define-with-contract account-withdraw
          (require (<= amount account-balance)
                   (>= amount 0))
          (ensure (>= <?> 0))
          (λ (amount account-balance)
            (- account-balance amount)))
        (account-withdraw 5 12)))

    (test-assert "define-with-contract - simple number contract works"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         'account-withdraw)
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(<= amount account-balance)
                            (exception-irritants exn)))
               #t])
        (begin
          (define-with-contract account-withdraw
            (require (<= amount account-balance)
                     (>= amount 0))
            (ensure (>= <?> 0))
            (λ (amount account-balance)
              (- account-balance amount)))
          (account-withdraw 100 90))))

    (test-assert "define-with-contract - simple number contract works with negative numbers"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         'account-withdraw)
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(>= amount 0)
                            (exception-irritants exn)))
               #t])
        (begin
          (define-with-contract account-withdraw
            (require (<= amount account-balance)
                     (>= amount 0))
            (ensure (>= <?> 0))
            (λ (amount account-balance)
              (- account-balance amount)))
          (account-withdraw -15 -10)))))

  (test-group "define*-with-contract"
    (test-eqv "define*-with-contract - does not raise an exception when not violated - long form"
      55
      (begin
        (define*-with-contract account-withdraw
          (require (<= amount account-balance)
                   (>= amount 0))
          (ensure (>= <?> 0))
          (amount account-balance #:optional (fee 0) #:key (tip 10))
          (- account-balance
             amount
             fee
             tip))
        (account-withdraw 50 120 5 #:tip 10)))

    (test-eqv "define*-with-contract - does not raise an exception when not violated - short form"
      55
      (begin
        (define*-with-contract (account-withdraw amount
                                                 account-balance
                                                 #:optional (fee 0)
                                                 #:key (tip 10))
          (require (<= amount account-balance)
                   (>= amount 0))
          (ensure (>= <?> 0))
          (- account-balance
             amount
             fee
             tip))
        (account-withdraw 50 120 5 #:tip 10)))

    (test-assert "define*-with-contract - simple number contract works"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         'account-withdraw-extra)
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(>= result 0)
                            (exception-irritants exn)))
               #t])
        (begin
          (define*-with-contract account-withdraw-extra
            (require (<= amount account-balance)
                     (>= amount 0))
            (ensure (>= <?> 0))
            (amount account-balance #:optional (fee 0) #:key (tip 10))
            (- account-balance
               amount
               fee
               tip))
          (account-withdraw-extra 50 90 30 #:tip 15))))

    (test-assert "define*-with-contract - number contract works with negative numbers"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         'account-withdraw-extra)
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(>= result 0)
                            (exception-irritants exn)))
               #t])
        (begin
          (define*-with-contract account-withdraw-extra
            (require (<= amount account-balance))
            (ensure (>= <?> 0))
            (amount account-balance #:optional (fee 0) #:key (tip 10))
            (- account-balance
               amount
               fee
               tip))
          (account-withdraw-extra -20 10 30 #:tip 1)))))

  (test-group "lambda-aliases"
    (test-equal "λ*-with-contract - contract does not raise an exception when not violated"
      "00234"
      ((λ*-with-contract
        (require (integer? num)
                 (char? padding-char)
                 (integer? padding-length)
                 (or (positive? padding-length)
                     (zero? padding-length)))
        (ensure (string? <?>)
                (>= (string-length <?>) padding-length))
        (num padding-char padding-length)
        (let* ([num-as-str (number->string num)]
               [len-diff (- padding-length
                            (string-length num-as-str))])
          (cond
           [(positive? len-diff)
            (call-with-output-string
              (λ (port)
                (let iter ([counter 0])
                  (cond
                   [(< counter len-diff)
                    (display padding-char port)
                    (iter (+ counter 1))]
                   [else
                    (display num-as-str port)]))))]
           [else num-as-str]))) 234 #\0 5))

    (test-eqv "λ-with-contract - contract does not raise an exception when not violated"
      7
      ((λ-with-contract
        (require (<= amount account-balance)
                 (>= amount 0))
        (ensure (>= <?> 0))
        (amount account-balance)
        (- account-balance amount)) 5 12)))

  (test-group "rest-argument-definitions"
    (test-equal "define-with-contract - with rest args - contract does not raise an exception when not violated"
      5
      (begin
        (define-with-contract account-withdraw
          (require (<= amount account-balance)
                   (fold (λ (current accumulated)
                           (and accumulated current))
                         #t
                         (map positive? other-fees)))
          (ensure (>= <?> 0))
          (amount account-balance . other-fees)
          (apply - account-balance amount other-fees))
        (account-withdraw 40 100 50 5)))

    (test-equal "define*-with-contract - with rest args - contract does not raise an exception when not violated"
      10
      (begin
        (define*-with-contract account-withdraw
          (require (<= amount account-balance)
                   (fold (λ (current accumulated)
                           (and accumulated current))
                         #t
                         (map positive? other-fees)))
          (ensure (>= <?> 0))
          (amount account-balance #:optional (fee1 5) #:key (fee2 10) . other-fees)
          (apply -
                 account-balance
                 amount
                 fee1
                 fee2
                 other-fees))
        (account-withdraw 40 100 30 1 2 3 4)))

    (test-assert "define*-with-contract - with rest args - raises for require violation"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         'account-withdraw)
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(<= amount account-balance)
                            (exception-irritants exn)))
               #t])
        (begin
          (define*-with-contract account-withdraw
            (require (<= amount account-balance)
                     (fold (λ (current accumulated)
                             (and accumulated current))
                           #t
                           (map positive? other-fees)))
            (ensure (>= <?> 0))
            (amount account-balance #:optional (fee1 5) #:key (fee2 10) . other-fees)
            (apply -
                   account-balance
                   amount
                   fee1
                   fee2
                   other-fees))
          (account-withdraw 400 100))))

    (test-assert "define*-with-contract - with rest args - raises for ensure violation"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         'account-withdraw)
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(>= result 0)
                            (exception-irritants exn)))
               #t])
        (begin
          (define*-with-contract account-withdraw
            (require (<= amount account-balance)
                     (fold (λ (current accumulated)
                             (and accumulated current))
                           #t
                           (map positive? other-fees)))
            (ensure (>= <?> 0))
            (amount account-balance #:optional (fee1 5) #:key (fee2 10) . other-fees)
            (apply -
                   account-balance
                   amount
                   fee1
                   fee2
                   200
                   other-fees))
          (account-withdraw 50 100))))

    (test-assert "define*-with-contract - with rest args - raises for violation of rest args"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         'account-withdraw)
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(fold (λ (current accumulated)
                                     (and accumulated current))
                                   #t
                                   (map positive? other-fees))
                            (exception-irritants exn)))
               #t])
        (begin
          (define*-with-contract account-withdraw
            (require (<= amount account-balance)
                     (fold (λ (current accumulated)
                             (and accumulated current))
                           #t
                           (map positive? other-fees)))
            (ensure (>= <?> 0))
            (amount account-balance #:optional (fee1 5) #:key (fee2 10) . other-fees)
            (apply -
                   account-balance
                   amount
                   fee1
                   fee2
                   200
                   other-fees))
          (account-withdraw 50 100 1 2 3 4 -5))))

    (test-assert "lambda*-with-contract - with rest args - works"
      (guard (exn
              [(and (contract-violated-exception? exn)
                    ;; check message
                    (exception-with-message? exn)
                    (string=? (exception-message exn)
                              "contract violated")
                    ;; check origin
                    (exception-with-origin? exn)
                    (eq? (exception-origin exn)
                         "unknown origin")
                    ;; check irritants
                    (exception-with-irritants? exn)
                    (equal? '(fold (λ (current accumulated)
                                     (and accumulated current))
                                   #t
                                   (map positive? other-fees))
                            (exception-irritants exn)))
               #t])
        ((lambda*-with-contract
          (require (<= amount account-balance)
                   (fold (λ (current accumulated)
                           (and accumulated current))
                         #t
                         (map positive? other-fees)))
          (ensure (>= <?> 0))
          (amount account-balance #:optional (fee1 5) #:key (fee2 10) . other-fees)
          (apply -
                 account-balance
                 amount
                 other-fees)) 50 100 1 2 3 4 -5)))))

(test-end "test")



;; ====================
;; c-list->vector usage
;; ====================

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

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