guile-semver/semver/structs.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 structs)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (make-semantic-version
	    semantic-version-major
	    semantic-version-minor
	    semantic-version-patch
	    semantic-version-pre-release
	    semantic-version-build-metadata
	    make-semantic-version*
            inc-semantic-version))

(define-immutable-record-type <semantic-version>
  (make-semantic-version major minor patch pre-release build-metadata)
  semantic-version?
  (major semantic-version-major set-semantic-version-major) ;; integer
  (minor semantic-version-minor set-semantic-version-minor) ;; integer
  (patch semantic-version-patch set-semantic-version-patch) ;; integer
  (pre-release semantic-version-pre-release
	       set-semantic-version-pre-release) ;; list<int|string>
  (build-metadata semantic-version-build-metadata
		  set-semantic-version-build-metadata)) ;; list<int|string>

(define* (make-semantic-version* major
				 #:optional
				 (minor "0")
				 (patch "0")
				 (pre-release '()) (build '()))
  (make-semantic-version (string->number major)
			 (string->number minor)
			 (string->number patch)
			 pre-release
			 build))

(define (print-semantic-version record port)
  (define (object->string* object)
    (if (string? object)
	object
	(object->string object)))
  (write-char #\[ port)
  (display (semantic-version-major record) port)
  (display #\. port)
  (display (semantic-version-minor record) port)
  (display #\. port)
  (display (semantic-version-patch record) port)
  (let ((pre-release (semantic-version-pre-release record)))
    (when (not (null? pre-release))
      (display #\- port)
      (display (string-join (map object->string* pre-release) ".") port)))
  (let ((build-metadata (semantic-version-build-metadata record)))
    (when (not (null? build-metadata))
      (display #\+ port)
      (display (string-join (map object->string* build-metadata) ".") port)))
  (write-char #\] port))

(set-record-type-printer! <semantic-version> print-semantic-version)

(define (inc-prerelease-list lst)
  "Ontological increment of LST. Increment right-most number by one,
or append the number 0 to lst."
  (let loop ((acc '()) (done #f) (rest (reverse lst)))
    (cond
     ((and (null? rest) (not done))
      (append lst '(0)))
     ((null? rest)
      acc)
     (else
      (apply loop
	     (let ((head (car rest)))
	       (if (number? head)
		   (list (cons (+ 1 head) acc)
			 #t
			 (cdr rest))
		   (list (cons head acc)
			 done
			 (cdr rest)))))))))

(define* (inc-semantic-version semver #:optional (level 'patch))
  "Increment the LEVEL part of SEMVER to the subsequent ontological
value. Valid values of LEVEL are 'major, 'minor, 'patch, 'premajor, 'preminor,
'prepatch or 'prerelease. The default is 'patch."
  (if (not (semantic-version? semver))
      (error (format #f "~a is not a semantic-version record" semver))
      (match level
        ('major
         (make-semantic-version (+ 1 (semantic-version-major semver))
                                0
                                0
                                '() 
                                '()))
        ('minor
         (make-semantic-version (semantic-version-major semver)
                                (+ 1 (semantic-version-minor semver))
                                0
				'()
				'()))
        ('patch
         (make-semantic-version (semantic-version-major semver)
                                (semantic-version-minor semver)
                                (+ 1 (semantic-version-patch semver))
				'()
				'()))
	('premajor
         (make-semantic-version (+ 1 (semantic-version-major semver))
                                0
                                0
                                '(0) 
                                '()))
	('preminor
         (make-semantic-version (semantic-version-major semver)
                                (+ 1 (semantic-version-minor semver))
                                0
                                '(0) 
                                '()))
	('prepatch
         (make-semantic-version (semantic-version-major semver)
                                (semantic-version-minor semver)
                                (+ 1 (semantic-version-patch semver))
                                '(0) 
                                '()))
	('prerelease
         (make-semantic-version (semantic-version-major semver)
                                (semantic-version-minor semver)
                                (semantic-version-patch semver)
				(inc-prerelease-list
				 (semantic-version-pre-release semver))
                                '()))
	
        (_
         (error (format #f "Undefined inc-level: ~a" level))))))