guile/test-suite/tests/match.test

;;;; match.test --- (ice-9 match)  -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010, 2011, 2012, 2021 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-match)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (test-suite lib))

(define exception:match-error
  (cons 'match-error "^.*$"))

(define-record-type rtd-2-slots
  (make-2-slot-record a b)
  two-slot-record?
  (a slot-first)
  (b slot-second))

(define-record-type rtd-3-slots
  (make-3-slot-record a b c)
  three-slot-record?
  (a slot-one)
  (b slot-two)
  (c slot-three))


(with-test-prefix "matches"

  (pass-if "wildcard"
    (match "hello" (_ #t)))

  (pass-if "symbol"
    (match 'foo ('foo #t)))

  (pass-if "string"
    (match "bar" ("bar" #t)))

  (pass-if "number"
    (match 777 (777 #t)))

  (pass-if "char"
    (match #\g (#\g #t)))

  (pass-if "sexp"
    (match '(a b c) ('(a b c) #t)))

  (pass-if "predicate"
    (match '(a 1 2)
      (('a (and (? odd?) one) (? even?))
       (= one 1))))

  (pass-if "list"
    (let ((lst '(a b c)))
      (match lst
        ((x y z)
         (equal? (list x y z) lst)))))

  (pass-if "list rest..."
    (let ((lst '(a b c)))
      (match lst
        ((x rest ...)
         (and (eq? x 'a) (equal? rest '(b c)))))))

  (pass-if "list . rest"
    (let ((lst '(a b c)))
      (match lst
        ((x . rest)
         (and (eq? x 'a) (equal? rest '(b c)))))))

  (pass-if "list ..1"
    (match '(a b c)
      ((x ..1)
       (equal? x '(a b c)))))

  (pass-if "list ..1, with predicate"
    (match '(a b c)
      (((and x (? symbol?)) ..1)
       (equal? x '(a b c)))))

  (pass-if "list ..1, nested"
    (match '((1 2) (3 4))
      (((x ..1) ..1)
       (equal? x '((1 2) (3 4))))))

  (pass-if "tree"
    (let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
      (match tree
        (('one ('two x) ('three y ('and z '(and 5))))
         (equal? (list x y z) '(2 3 4))))))

  (pass-if "and, unique names"
    (let ((tree '(1 2)))
      (match tree
        ((and (a 2) (1 b))
         (equal? 3 (+ a b))))))
  
  (pass-if "and, same names"
    (let ((a '(1 2)))
      (match a
        ((and (a 2) (1 b))
         (equal? 3 (+ a b))))))
  
  (with-test-prefix "records"

    (pass-if "all slots, bind"
      (let ((r (make-3-slot-record 1 2 3)))
        (match r
          (($ rtd-3-slots a b c)
           (equal? (list a b c) '(1 2 3))))))

    (pass-if "all slots, literals"
      (let ((r (make-3-slot-record 1 2 3)))
        (match r
          (($ rtd-3-slots 1 2 3)
           #t))))

    (pass-if "2 slots"
      (let ((r (make-3-slot-record 1 2 3)))
        (match r
          (($ rtd-3-slots x y)
           (equal? (list x y) '(1 2))))))

    (pass-if "RTD correctly checked"
      (let ((r (make-2-slot-record 1 2)))
        (match r
          (($ rtd-3-slots a b)
           #f)
          (($ rtd-2-slots a b)
           (equal? (list a b) '(1 2))))))

    (pass-if "getter"
      (match (make-2-slot-record 1 2)
        (($ rtd-2-slots (get! first) (get! second))
         (equal? (list (first) (second)) '(1 2)))))

    (pass-if "setter"
      (let ((r (make-2-slot-record 1 2)))
        (match r
          (($ rtd-2-slots (set! set-first!) (set! set-second!))
           (set-first! 'one)
           (set-second! 'two)
           (equal? (list (slot-first r) (slot-second r))
                   '(one two))))))))


(with-test-prefix "doesn't match"

  (pass-if-exception "tree"
    exception:match-error
    (match '(a (b c))
      ((foo (bar)) #t)))

  (pass-if-exception "list ..1"
    exception:match-error
    (match '()
      ((x ..1) #f)))

  (pass-if-exception "list ..1, with predicate"
    exception:match-error
    (match '(a 0)
      (((and x (? symbol?)) ..1)
       (equal? x '(a b c)))))

  (with-test-prefix "records"

    (pass-if "not a record"
      (match "hello"
        (($ rtd-2-slots) #f)
        (_               #t)))

    (pass-if-exception "too many slots"
      exception:out-of-range
      (let ((r (make-3-slot-record 1 2 3)))
        (match r
          (($ rtd-3-slots a b c d)
           #f))))))

(with-test-prefix "unify in list patterns"
  (pass-if-equal "matching" '(1 2 3)
    (match '((1 2 3) (1 2 3))
      (((x ...) (x ...)) x)
      (_ #f)))

  (pass-if-equal "not matching" #f
    (match '((1 2 3) (1 2 3 4))
      (((x ...) (x ...)) x)
      (_ #f))))


;;;
;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
;;;

(let-syntax ((load       (syntax-rules ()
                           ((_ file) #t)))
             (test       (syntax-rules ()
                           ((_ name expected expr)
                            (pass-if name
                                     (equal? expected expr)))))
             (test-begin (syntax-rules ()
                           ((_ name) #t)))
             (test-end   (syntax-rules ()
                           ((_) #t))))
  (with-test-prefix "upstream tests"
    (include-from-path "tests/match.test.upstream")))