source: project/release/5/semantic-version/trunk/semantic-version.scm @ 39935

Last change on this file since 39935 was 39935, checked in by Kon Lovett, 5 months ago

add template module (version protocols - ohh), better err msg proc names

File size: 16.4 KB
Line 
1;;;; semantic-version.scm  -*- Scheme -*-
2;;;; Kon Lovett, Apr '21
3
4;; Issues
5;;
6;; - Support Roman Numerals & Upper/Lowercase Letters ("outline numbers").
7;;
8;; - Change representation to vector "arms".
9;;
10;; - Better name for `version-depth+/-': `version-depth-extend/retract'?
11;;
12;; - Version Protocols: major#.minor#[.point#][;fix#[-reason$]]
13;;   where <alpha>+ name, <separator> char, [] optional ([] & [...[ ]]), # number & $ string
14;;   w/ both otherwise
15
16#|
17(define vp1 (string->version-protocol "major#.minor#[.point#][;fix[-reason$]]"))
18(version-protocol->string vp1) ;=> "major#.minor#[.point#][;fix[-reason$]]"
19
20(version-protocol-template "major#" #\. minor# (#\. point#) (#\; "fix" (#\- reason$))) ;str|sym
21
22(version-protocol- vp1 )
23|#
24
25(module semantic-version
26
27(;export
28  version-punctuation
29  version-tail-zero
30  make-version
31  version
32  version-copy
33  version? check-version error-version
34  version-depth
35  version-elements
36  version-separators
37  list->version
38  version->list
39  version-compare
40  version<? version=? version>? version<=? version>=?
41  version-hash
42  ;version*<? version*=? version*>? version*<=? version*>=?
43  ;version*-hash
44  version-comparator
45  string->version
46  version->string
47  version-depth+!
48  version-depth-!
49  version-depth+
50  version-depth-
51  version-extend!
52  version-extend
53  version-inc! version-dec!
54  version-inc version-dec)
55
56(import scheme
57  utf8
58  (chicken base)
59  (chicken type)
60  (chicken condition)
61  (chicken format)
62  (only (chicken string) ->string string-compare3)
63  (only (srfi 1) make-list list-copy drop-while every reverse! append! drop-right! map!)
64  (only utf8-srfi-13 string-filter string-index)
65  (only (srfi 69) equal?-hash)
66  (only (srfi 128) make-comparator))
67
68;;record-variants
69
70(define-syntax define-record-type-variant
71  (er-macro-transformer
72   (lambda (form r c)
73     (define (any p L)
74       (and (pair? L)
75            (or (p (car L))
76                (any p (cdr L)))))
77     (##sys#check-syntax 'define-record-type-variant form
78                         '(_ _ #(variable 0)
79                             #(variable 1) _ . _))
80     (let* ((name-spec (cadr form))
81            (name (if (pair? name-spec) (car name-spec) name-spec))
82            (t (if (pair? name-spec) (cadr name-spec) name-spec))
83            (variant? (lambda (type) (any (lambda (x) (c x (r type)))
84                                          (caddr form))))
85            (unsafe? (variant? 'unsafe))
86            (unchecked? (variant? 'unchecked))
87            (inline? (variant? 'inline))
88            (constructor? (eq? name t))
89
90            (conser (cadddr form))
91            (predspec (car (cddddr form)))
92            (pred (if (pair? predspec) (car predspec) predspec))
93            (checker (if (and (pair? predspec)
94                              (pair? (cdr predspec)))
95                         (cadr predspec) #f))
96            (slots (cdr (cddddr form)))
97            (%begin (r 'begin))
98            (%lambda (r 'lambda))
99            (%define (if inline? (r 'define-inline) (r 'define)))
100            (vars (cdr conser))
101            (x (r 'x))
102            (y (r 'y))
103            (%getter-with-setter (r 'getter-with-setter))
104            (slotnames (map car slots)))
105       `(,%begin
106         ,(if constructor?
107              `(,%define ,conser
108                         (##sys#make-structure
109                          ,t
110                          ,@(map (lambda (sname)
111                                   (if (memq sname vars)
112                                       sname
113                                       '(##core#undefined)))
114                                 slotnames)))
115              `(,%begin))
116         (,%define (,pred ,x) (##sys#structure? ,x ,t))
117         ,(if checker
118              `(,%define (,checker ,x)
119                         (##core#check (##sys#check-structure ,x ,t)))
120              `(,%begin))
121         ,@(let loop ([slots slots] [i 1])
122             (if (null? slots)
123                 '()
124                 (let* ([slot (car slots)]
125                        (setters (memq #:record-setters ##sys#features))
126                        (setr? (pair? (cddr slot)))
127                        (getr `(,%lambda (,x)
128                                         ,(if unchecked?
129                                              `(,%begin)
130                                              `(##core#check
131                                                (##sys#check-structure ,x ,t)))
132                                         ,(if unsafe?
133                                              `(##sys#slot ,x ,i)
134                                              `(##sys#block-ref ,x ,i)))))
135                   `(,@(if setr?
136                           `((,%define (,(caddr slot) ,x ,y)
137                                       ,(if unchecked?
138                                            `(,%begin)
139                                            `(##core#check
140                                              (##sys#check-structure ,x ,t)))
141                                       ,(if unsafe?
142                                            `(##sys#setslot ,x ,i ,y)
143                                            `(##sys#block-set! ,x ,i ,y))))
144                           '())
145                     (,%define ,(cadr slot)
146                               ,(if (and setr? setters)
147                                    `(,%getter-with-setter ,getr ,(caddr slot))
148                                    getr) )
149                     ,@(loop (cdr slots) (add1 i)))))))))))
150
151;;
152
153;NOTE symbols are not preserved; the printname is used!
154(define-type ver-part  (or number string symbol))
155(define-type ver-punc  char)
156(define-type ver-parts (list-of ver-part))
157(define-type ver-puncs (list-of ver-punc))
158(define-type ver       (struct semantic-version))
159
160(: version-punctuation  (#!optional string -> string))
161(: version-tail-zero    (#!optional boolean -> boolean))
162
163(: make-version         (integer #!optional ver-part ver-punc --> ver))
164(: version              (#!rest ver-part --> ver))
165(: version?             (* -> boolean : ver))
166(: check-version        (symbol * #!optional (or string symbol) -> ver))
167(: error-version        (symbol * #!optional (or string symbol) -> void))
168(: version-copy         (ver --> ver))
169(: version-depth        (ver --> integer))
170(: version-elements     (ver --> ver-parts))
171(: version-separators   (ver --> ver-puncs))
172(: list->version        ((list-of (or ver-part ver-punc)) --> ver))
173(: version->list        (ver --> (list-of (or ver-part ver-punc))))
174(: version-compare      (ver ver #!optional boolean --> integer))
175(: version<?            (ver ver #!optional boolean --> boolean))
176(: version=?            (ver ver #!optional boolean --> boolean))
177(: version>?            (ver ver #!optional boolean --> boolean))
178(: version<=?           (ver ver #!optional boolean --> boolean))
179(: version>=?           (ver ver #!optional boolean --> boolean))
180(: version-hash         (ver #!rest --> integer))
181(: version-comparator   (--> (struct comparator)))
182(: string->version      (string --> ver))
183(: version->string      (ver --> string))
184(: version-extend!      (ver #!rest (or ver-part ver-punc) -> ver))
185(: version-extend       (ver #!rest (or ver-part ver-punc) --> ver))
186(: version-depth+!      (ver integer #!optional ver-part ver-punc -> ver))
187(: version-depth-!      (ver integer -> ver))
188(: version-depth+       (ver integer #!optional ver-part ver-punc --> ver))
189(: version-depth-       (ver integer --> ver))
190(: version-inc!         (ver #!optional integer number -> ver))
191(: version-dec!         (ver #!optional integer number -> ver))
192(: version-inc          (ver #!optional integer number --> ver))
193(: version-dec          (ver #!optional integer number --> ver))
194
195;;
196
197;semantic-version type
198
199;NOTE symbols are not preserved; the printname is used!
200(define (ver-part? x) (or (number? x) (string? x) (symbol? x)))
201(define (ver-punc? x) (char? x))
202
203(define semantic-version 'semantic-version)
204(define-record-type-variant semantic-version (unsafe unchecked inline)
205  (make-ver cs ps)
206  ver?
207  (cs ver-parts ver-parts-set!)
208  (ps ver-puncs ver-puncs-set!))
209
210(define (vertyp? x) (and (ver? x) (list? (ver-parts x)) (list? (ver-puncs x))))
211
212(define (copy-ver v) (make-ver (list-copy (ver-parts v)) (list-copy (ver-puncs v))))
213
214(define (ver-parts? l) (every ver-part? l))
215(define (ver-puncs? l) (every ver-punc? l))
216
217(define (badargmsg msg #!optional nam)
218  (string-append (or (and nam (->string nam)) "bad argument") " - " msg) )
219
220(define (badargerr loc obj msg #!optional nam)
221  (error loc (badargmsg msg nam) obj) )
222
223(define (check-parts loc x #!optional nam)
224  (unless (ver-parts? x) (badargerr loc x "invalid semantic-version parts" nam))
225  x )
226
227(define (check-puncs loc x #!optional nam)
228  (unless (ver-puncs? x) (badargerr loc x "invalid semantic-version puncs" nam))
229  x )
230
231;
232
233;"!?@#$%^&*-_+=|/\\;:,. "
234;"#$%^&-_+=/\\;:,. "
235;"._- +;:,"
236(define-constant VERSION-PUNCT "._- +;:,")
237
238(define version-punctuation (make-parameter VERSION-PUNCT))
239
240(define version-tail-zero (make-parameter #f))
241
242(define (drop-tailing-zeros ls)
243  (reverse! (drop-while (lambda (x) (and (number? x) (zero? x))) (reverse ls))) )
244
245(define (default-punctuation)
246  (string-ref (version-punctuation) 0) )
247
248(define (default-puncs parts)
249  (make-list (sub1 (length parts)) (default-punctuation)) )
250
251(define (make-version cnt #!optional (part 0) (punc (default-punctuation)))
252  (check-parts 'make-version (list part))
253  (check-puncs 'make-version (list punc))
254  (make-ver (make-list cnt part) (make-list (min 0 (sub1 cnt)) punc)) )
255
256(define (version . parts)
257  (if (null? (check-parts 'version parts)) (make-ver '() '())
258    (let ((parts (map (lambda (x) (if (symbol? x) (symbol->string x) x)) parts)))
259      (make-ver parts (default-puncs parts))) ) )
260
261(define (version? ver)
262  (and
263    (vertyp? ver)
264    (let ((parts (ver-parts ver)) (puncs (ver-puncs ver)))
265      (or
266        (and (null? puncs) (null? parts))
267        (and
268          (= (length puncs) (sub1 (length parts)))
269          (ver-parts? parts)
270          (ver-puncs? puncs) ) ) ) ) )
271
272(define (error-version loc x #!optional nam)
273  (badargerr loc x "invalid semantic-version" nam) )
274
275(define (check-version loc x #!optional nam)
276  (unless (vertyp? x) (error-version loc x nam))
277  (check-parts loc (ver-parts x) nam)
278  (check-puncs loc (ver-puncs x) nam)
279  x )
280
281(define (version-copy ver)
282  (copy-ver (check-version 'version-copy ver)) )
283
284(define (version-depth ver)
285  (length (ver-parts (check-version 'version-depth ver))) )
286
287(define (version-elements ver)
288  (list-copy (ver-parts (check-version 'version-elements ver))) )
289
290(define (version-separators ver)
291  (list-copy (ver-puncs (check-version 'version-separators ver))) )
292
293(define (version->list ver)
294  (check-version 'version->list ver)
295  (let loop ((puncs (ver-puncs ver)) (parts (ver-parts ver)) (ls '()))
296    (cond
297      ((and (null? puncs) (null? parts))
298        (reverse! ls) )
299      ((= (length puncs) (length parts))
300        (loop (cdr puncs) parts (cons (car puncs) ls)) )
301      (else
302        (loop puncs (cdr parts) (cons (car parts) ls)) ) ) ) )
303
304(define (list->version ls)
305  (define (str/num x) (if (number? x) x (->string x)))
306  (let loop ((parts '()) (puncs '()) (ls ls))
307    (cond
308      ((null? ls)             (make-ver (reverse! parts) (reverse! puncs)))
309      ((ver-part? (car ls))   (loop (cons (str/num (car ls)) parts) puncs (cdr ls)))
310      ((ver-punc? (car ls))   (loop parts (cons (car ls) puncs) (cdr ls)))
311      (else
312        (error 'list->version "invalid version component" (car ls))) ) ) )
313
314(define (version-compare ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
315  (define (tail-zeros ls) (if tail-zero? ls (drop-tailing-zeros ls)))
316  (let loop ((p1 (tail-zeros (ver-parts (check-version 'version-compare ver1))))
317             (p2 (tail-zeros (ver-parts (check-version 'version-compare ver2)))))
318    (cond
319      ((and (null? p1) (null? p2))  0)
320      ((null? p1)                   -1)
321      ((null? p2)                   1)
322      ((and (number? (car p1)) (number? (car p2)))
323        (let ((cmp (- (car p1) (car p2))))
324          (if (zero? cmp) (loop (cdr p1) (cdr p2))
325            cmp ) ) )
326      ((number? (car p1))           -1)
327      ((number? (car p2))           1)
328      ((string-compare3 (car p1) (car p2)) =>
329        (lambda (cmp)
330          (if (zero? cmp) (loop (cdr p1) (cdr p2))
331            cmp ) ) ) ) ) )
332
333(define (version<? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
334  (negative? (version-compare ver1 ver2 tail-zero?)) )
335
336(define (version=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
337  (zero? (version-compare ver1 ver2 tail-zero?)) )
338
339(define (version>? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
340  (positive? (version-compare ver1 ver2 tail-zero?)) )
341
342(define (version<=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
343  (<= (version-compare ver1 ver2 tail-zero?) 0) )
344
345(define (version>=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
346  (>= (version-compare ver1 ver2 tail-zero?) 0) )
347
348(define (version-hash ver . rest)
349  (define (tail-zeros ls) (if (version-tail-zero) ls (drop-tailing-zeros ls)))
350  (apply equal?-hash (tail-zeros (ver-parts (check-version 'version-hash ver))) rest) )
351
352#;
353(define (version*=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
354  (and
355    (zero? (version-compare ver1 ver2 tail-zero?))
356    (equal? (ver-puncs1 ver) (ver-puncs ver2))) )
357
358#;
359(define (version*-hash ver . rest)
360  (equal?-hash (check-version 'version-hash* ver) rest) )
361
362(define (version-comparator)
363  (make-comparator version? version=? version<? version-hash) )
364
365;string-utils like
366;"..." => string-parts char-puncs
367;"a.3,c" => ("a" "3" "c") (#\. #\,)
368(define (*string-unzip str punc-str)
369  (let (
370    (parts (string-split str punc-str #t))
371    (punct (string->list (string-filter (cut string-index punc-str <>) str))) )
372    (values parts punct) ) )
373
374(define (string->version str)
375  (define (str/num x) (or (string->number x) x))
376  (let-values (((parts puncs) (*string-unzip str (version-punctuation))))
377    (make-ver (map! str/num parts) puncs) ) )
378
379(define (version->string ver)
380  (apply string-append (map! ->string (version->list (check-version 'version->string ver)))) )
381
382(define (version-depth+! ver cnt #!optional (part 0) (punc (default-punctuation)))
383  (check-version 'version-depth+! ver)
384  (check-parts 'version-depth+! (list part))
385  (check-puncs 'version-depth+! (list punc))
386  (ver-parts-set! ver (append! (ver-parts ver) (make-list cnt part)))
387  ;need to include leading punct!
388  (ver-puncs-set! ver (append! (ver-puncs ver) (make-list cnt punc)))
389  ver )
390
391(define (version-depth-! ver cnt)
392  (check-version 'version-depth-! ver)
393  (cond
394    ((zero? cnt)
395      ver )
396    ((positive? cnt)
397      (let ((puncs (ver-puncs ver)) (parts (ver-parts ver)))
398        (unless (<= cnt (length parts))
399          (error 'version-depth-! "semantic-version cannot drop such depth" ver cnt) )
400        ;be direct when dropping all
401        (ver-parts-set! ver (if (= cnt (length parts)) '() (drop-right! parts cnt)))
402        ;need to drop leading punctuation
403        (ver-puncs-set! ver (if (= cnt (length parts)) '() (drop-right! puncs cnt)))
404        ver ) )
405    (else
406      (error 'version-depth-! "semantic-version cannot drop negative depth" ver cnt)) ) )
407
408(define (version-depth+ ver cnt #!optional (part 0) (punc (default-punctuation)))
409  (version-depth+! (copy-ver (check-version 'version-depth+ ver)) cnt part punc) )
410
411(define (version-depth- ver cnt)
412  (version-depth-! (copy-ver (check-version 'version-depth- ver)) cnt) )
413
414(define (version-extend ver . comps)
415  (list->version (append! (version->list (check-version 'version-extend ver)) comps)) )
416
417(define (version-extend! ver . comps)
418  (let ((vern (apply version-extend (check-version 'version-extend! ver) comps)))
419    (ver-parts-set! ver (ver-parts vern))
420    (ver-puncs-set! ver (ver-puncs vern)) )
421  ver )
422
423;default is the last component, better be a number!
424(define (version-inc! ver #!optional idx (amt 1))
425  (check-version 'version-inc! ver)
426  (let loop ((idx (or idx (sub1 (length (ver-parts ver))))) (ls (ver-parts ver)))
427    (if (positive? idx) (loop (sub1 idx) (cdr ls))
428      (begin
429        (set-car! ls (+ (car ls) amt))
430        ver ) ) ) )
431
432(define (version-dec! ver #!optional idx (amt 1))
433  (version-inc! (check-version 'version-dec! ver) idx (- amt)) )
434
435(define (version-inc ver #!optional idx (amt 1))
436  (version-inc! (copy-ver (check-version 'version-inc ver)) idx amt) )
437
438(define (version-dec ver #!optional idx (amt 1))
439  (version-dec! (copy-ver (check-version 'version-dec ver)) idx amt) )
440
441;; Read/Print Syntax
442
443(define (version-print ver out)
444  (format out "#<version ~S>" (version->string ver)) )
445
446;;;
447
448(set! (record-printer semantic-version) version-print)
449
450) ;module semantic-version
Note: See TracBrowser for help on using the repository browser.