Changeset 40343 in project


Ignore:
Timestamp:
08/19/21 21:26:31 (5 weeks ago)
Author:
Kon Lovett
Message:

split into separate modules

Location:
release/5/semantic-version/trunk
Files:
7 added
1 deleted
2 edited

Legend:

Unmodified
Added
Removed
  • release/5/semantic-version/trunk/semantic-version.egg

    r39935 r40343  
    33
    44((synopsis "Semantic Version Utilities")
    5  (version "0.0.4")
     5 (version "0.0.3")
    66 (category data)
    77 (author "Kon Lovett")
     
    1010 (test-dependencies test)
    1111 (components
    12   (extension semantic-version-protocol
     12  (extension semantic-version.schema
    1313    (types-file)
    1414    (component-dependencies semantic-version)
    1515    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings") )
     16  (extension semantic-version.core
     17    (types-file)
     18    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings") )
     19  (extension semantic-version.element
     20    (types-file)
     21    (component-dependencies semantic-version.core)
     22    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings") )
     23  (extension semantic-version.compare
     24    (types-file)
     25    (component-dependencies semantic-version.core)
     26    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings") )
     27  (extension semantic-version.operation
     28    (types-file)
     29    (component-dependencies semantic-version.core)
     30    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings") )
    1631  (extension semantic-version
    1732    (types-file)
     33    (component-dependencies semantic-version.core semantic-version.element semantic-version.compare semantic-version.operation)
    1834    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings" "-no-procedure-checks-for-usual-bindings") ) ) )
  • release/5/semantic-version/trunk/semantic-version.scm

    r39935 r40343  
    22;;;; Kon Lovett, Apr '21
    33
    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
     4(module semantic-version ()
    155
    16 #|
    17 (define vp1 (string->version-protocol "major#.minor#[.point#][;fix[-reason$]]"))
    18 (version-protocol->string vp1) ;=> "major#.minor#[.point#][;fix[-reason$]]"
     6(import scheme (chicken module))
    197
    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)
     8(import
     9  (semantic-version core) (semantic-version element)
     10  (semantic-version compare) (semantic-version operation))
     11(reexport
     12  (semantic-version core) (semantic-version element)
     13  (semantic-version compare) (semantic-version operation))
    44914
    45015) ;module semantic-version
Note: See TracChangeset for help on using the changeset viewer.