;; Test case for globs2 format of the Shared MIME-Info Database
;;
;;  Copyright (C) 2014  Mike Gerwitz
;;
;;  This file is part of guile-mime.
;;
;;  guile-mime is free software: you can redistribute it and/or modify
;;  it under the terms of the GNU General Public License as published
;;  the Free Software Foundation, either version 3 of the License, or
;;  (at your option) any later version.
;;
;;  This program 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 General Public License for more details.
;;
;;  You should have received a copy of the GNU General Public License
;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; TODO: We should provide stronger assurances, as this does not
;; prevent a bogus implementation.



(define-module (test mime xdg globs2)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module (mime xdg globs2))



(define-syntax-rule (%make-test-match pattern test-expr)
  (match test-expr
    (pattern #t)
    (_ #f)))

(define-syntax test-match
  (syntax-rules ()
    ((test-match test-name pattern test-expr)
     (test-eq test-name
              #t
              (%make-test-match pattern test-expr)))
    ((test-match pattern test-expr)
     (test-eq #t
              (%make-test-match pattern test-expr)))))



(test-group
 "(mime xdg globs2)"

 (test-group
  "parse-mime-glob2"

  (test-match "comment yields empty record of class 'comment"
              ($ <mime-glob2> 'comment #f #f #f #f)
              (parse-mime-glob2 "#comment line"))

  (test-group
   "__NOGLOBS__ yields"
   
   (let* ((type "foo/noglobs")
          (r    (parse-mime-glob2
                 (string-append "10:" type ":__NOGLOBS__:cs" ))))

     (test-assert "<mime-glob2> record"
                  (mime-glob2? r))

     (test-eq "class of 'deleteall"
              (mime-glob2-class r)
              'deleteall)

     (test-assert "the given type"
                  (string=? type
                            (mime-glob2-type r)))

     (test-equal "weight of zero"
                 (mime-glob2-weight r)
                 0)

     (test-eq "no pattern"
              #f
              (mime-glob2-pattern r))

     (test-eq "no flags"
              #f
              (mime-glob2-flag r)))

   ;; tests both with and without flags
   (for-each
    (lambda (xs)
      (let ((group-desc (car xs))
            (flag       (cdr xs)))
        
        (test-group
         group-desc

         ;; flags will be tested below
         (let* ((type    "foo/flags")
                (weight  15)
                (pattern "*.foo")
                (r       (parse-mime-glob2
                          (string-append (number->string weight)
                                         ":" type
                                         ":" pattern
                                         flag))))

           (test-assert "<mime-glob2> record"
                        (mime-glob2? r))

           (test-eq "class of 'pattern"
                    (mime-glob2-class r)
                    'pattern)

           (test-assert "the given type"
                        (string=? type
                                  (mime-glob2-type r)))

           (test-equal "the given weight"
                       weight
                       (mime-glob2-weight r))

           (test-assert "the given pattern"
                        (string=? pattern
                                  (mime-glob2-pattern r)))))))
      '(("pattern with flag yields"    . ":foo")
        ("pattern without flag yields" . "")))

   (test-group
    "flag"

    (test-eq "yields #f when unknown"
             #f
             (mime-glob2-flag (parse-mime-glob2
                               "0:foo:*:unknown")))

    (test-eq "yields 'case-fold when `cs'"
             'case-fold
             (mime-glob2-flag (parse-mime-glob2
                               "0:foo:*:cs")))))))