guile-semver/semver/matcher.scm

;;; guile-semver --- Semantic Version tooling for guile
;;; Copyright © 2017 Jelle Dirk Licht <jlicht@fsfe.org>
;;;
;;; This file is part of guile-semver.
;;;
;;; guile-semver is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; guile-semver 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 guile-semver.  If not, see <http://www.gnu.org/licenses/>.

(define-module (semver matcher)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-67)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg)
  #:use-module (oop goops)
  #:use-module (rnrs enums)
  #:use-module (semver structs)
  #:use-module (semver comparator)
  #:export (semver-range-eq
	    semver-range-gt
	    semver-range-gte
	    semver-range-lt
	    semver-range-lte
	    semver-range-hyphen
	    semver-range-caret
	    semver-range-tilde
	    semver-range-partial
	    semver-range-or
	    semver-range-and
	    semver-range-matcher))

(define-immutable-record-type <semver-range>
  (make-semver-range matcher min max)
  semver-range?
  (matcher semver-range-matcher set-semver-range-matcher) ; (<semantic-version> -> bool)
  (min semver-range-min set-semver-range-min)		  ; (<semantic-version>)
  (max semver-range-max set-semver-range-max))		  ; (<semantic-version>)


;; Helpers
(define (semver-range-eq version)
  (make-semver-range (lambda (v)
		       (= 0 (semantic-version-compare version v)))
		     version
		     (inc-semantic-version version)))

(define (tiniest-min semver-range1 semver-range2)
  (let ((m1 (semver-range-min semver-range1))
	(m2 (semver-range-min semver-range2)))
    (match (semantic-version-compare m1 m2)
      ((-1) m1)
      ((1) m2)
      (else m1))))

(define (biggest-max semver-range1 semver-range2)
  (let ((m1 (semver-range-max semver-range1))
	(m2 (semver-range-max semver-range2)))
    (match (semantic-version-compare m1 m2)
      ((-1) m2)
      ((1) m1)
      (else m1))))

(define (semver-range-and semver-range1 semver-range2)
  (make-semver-range (lambda (v)
		       (and ((semver-range-matcher semver-range1) v)
			    ((semver-range-matcher semver-range2) v)))
		     (tiniest-min semver-range1 semver-range2)
		     (biggest-max semver-range1 semver-range2)))

(define (semver-range-or semver-range1 semver-range2)
  (make-semver-range (lambda (v)
		       (or ((semver-range-matcher semver-range1) v)
			   ((semver-range-matcher semver-range2) v)))
		     (tiniest-min semver-range1 semver-range2)
		     (biggest-max semver-range1 semver-range2)))

(define (semver-range-gt-base version)
  (make-semver-range (lambda (v)
		       (= -1 (semantic-version-compare version v)))
		     version
		     *semantic-version-max*))

(define (semver-range-gte-base version)
  (semver-range-or (semver-range-gt-base version)
		   (semver-range-eq version)))

(define (semver-range-lt-base version)
  (make-semver-range (lambda (v)
		       (= 1 (semantic-version-compare version v)))
		     *semantic-version-min*
		     version))

;; (define (semver-range-lte-base version)
;;   (semver-range-or (semver-range-lt-base version)
;; 		   (semver-range-eq version)))

(define (semver-range-min-max min max)
  (make-semver-range (lambda (v)
		       (and
			(= -1 (semantic-version-compare v max))
			(not (= -1 (semantic-version-compare v min)))))
		     min
		     max))

(define (semver-range-partial . rest)
  (semver-range-min-max (apply semantic-version-wildcard-min rest)
			(apply semantic-version-wildcard-max rest)))

(define (semver-range-lt semver-range)
  ;; maximum of new range is minimum of old range
  (let ((max (semver-range-min semver-range))) 
    (make-semver-range (lambda (v)
			 (= 1
			    (semantic-version-compare max v)))
		       *semantic-version-min*
		       max)))

(define (semver-range-gt semver-range)
  ;; minimum of new range is maximum of old range
  (let ((min (semver-range-max semver-range)))
    (make-semver-range (lambda (v)
			 (not (= -1
				 (semantic-version-compare v min))))
		       min
		       *semantic-version-max*)))

(define (semver-range-lte semver-range)
  (semver-range-lt-base (inc-semantic-version (semver-range-max semver-range))))

(define (semver-range-gte semver-range)
  (semver-range-gte-base (semver-range-min semver-range)))

(define (semver-range-hyphen semver-range1 semver-range2)
  (let ((min (semver-range-min semver-range1))
	(max (semver-range-max semver-range2)))
    (semver-range-min-max min max)))

(define (was-wildcard? min max)
  (not (= 0 (semantic-version-compare (inc-semantic-version min) max))))

(define (semver-range-tilde semver-range)
  (let ((min (semver-range-min semver-range))
	(max (semver-range-max semver-range)))
    (if (was-wildcard? min max)
	semver-range
	(semver-range-min-max min (inc-semantic-version max 'minor)))))

(define (left-most-nz version)
  (cond
   ((not (zero? (semantic-version-major version)))
    'major)
   ((not (zero? (semantic-version-minor version)))
    'minor)
   ((not (zero? (semantic-version-patch version))) 'patch)
   (else 'patch)))

(define (major-minor-zero? version)
  (and (zero? (semantic-version-major version))
       (zero? (semantic-version-minor version))))

(define (semver-range-caret semver-range)
  (let ((min (semver-range-min semver-range))
	(max (semver-range-max semver-range)))
    (if (and (was-wildcard? min max) (major-minor-zero? min))
	(semver-range-min-max min (inc-semantic-version min 'minor))
	(semver-range-min-max min (inc-semantic-version min (left-most-nz min))))))