source: project/release/5/semantic-version/trunk/semantic-version-protocol.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: 7.2 KB
Line 
1;;;; semantic-version-protocol.scm  -*- Scheme -*-
2;;;; Kon Lovett, Apr '21
3
4;; Issues
5;;
6
7(module semantic-version-protocol
8
9(;export
10  string->version-protocol version-protocol->string
11  list->version-protocol version-protocol->list
12  string->version/protocol
13  list->version/protocol)
14
15(import scheme
16  utf8
17  (chicken base)
18  (chicken type)
19  (only (srfi 1) list-copy every)
20  semantic-version)
21
22;;record-variants
23
24(define-syntax define-record-type-variant
25  (er-macro-transformer
26   (lambda (form r c)
27     (define (any p L)
28       (and (pair? L)
29            (or (p (car L))
30                (any p (cdr L)))))
31     (##sys#check-syntax 'define-record-type-variant form
32                         '(_ _ #(variable 0)
33                             #(variable 1) _ . _))
34     (let* ((name-spec (cadr form))
35            (name (if (pair? name-spec) (car name-spec) name-spec))
36            (t (if (pair? name-spec) (cadr name-spec) name-spec))
37            (variant? (lambda (type) (any (lambda (x) (c x (r type)))
38                                          (caddr form))))
39            (unsafe? (variant? 'unsafe))
40            (unchecked? (variant? 'unchecked))
41            (inline? (variant? 'inline))
42            (constructor? (eq? name t))
43
44            (conser (cadddr form))
45            (predspec (car (cddddr form)))
46            (pred (if (pair? predspec) (car predspec) predspec))
47            (checker (if (and (pair? predspec)
48                              (pair? (cdr predspec)))
49                         (cadr predspec) #f))
50            (slots (cdr (cddddr form)))
51            (%begin (r 'begin))
52            (%lambda (r 'lambda))
53            (%define (if inline? (r 'define-inline) (r 'define)))
54            (vars (cdr conser))
55            (x (r 'x))
56            (y (r 'y))
57            (%getter-with-setter (r 'getter-with-setter))
58            (slotnames (map car slots)))
59       `(,%begin
60         ,(if constructor?
61              `(,%define ,conser
62                         (##sys#make-structure
63                          ,t
64                          ,@(map (lambda (sname)
65                                   (if (memq sname vars)
66                                       sname
67                                       '(##core#undefined)))
68                                 slotnames)))
69              `(,%begin))
70         (,%define (,pred ,x) (##sys#structure? ,x ,t))
71         ,(if checker
72              `(,%define (,checker ,x)
73                         (##core#check (##sys#check-structure ,x ,t)))
74              `(,%begin))
75         ,@(let loop ([slots slots] [i 1])
76             (if (null? slots)
77                 '()
78                 (let* ([slot (car slots)]
79                        (setters (memq #:record-setters ##sys#features))
80                        (setr? (pair? (cddr slot)))
81                        (getr `(,%lambda (,x)
82                                         ,(if unchecked?
83                                              `(,%begin)
84                                              `(##core#check
85                                                (##sys#check-structure ,x ,t)))
86                                         ,(if unsafe?
87                                              `(##sys#slot ,x ,i)
88                                              `(##sys#block-ref ,x ,i)))))
89                   `(,@(if setr?
90                           `((,%define (,(caddr slot) ,x ,y)
91                                       ,(if unchecked?
92                                            `(,%begin)
93                                            `(##core#check
94                                              (##sys#check-structure ,x ,t)))
95                                       ,(if unsafe?
96                                            `(##sys#setslot ,x ,i ,y)
97                                            `(##sys#block-set! ,x ,i ,y))))
98                           '())
99                     (,%define ,(cadr slot)
100                               ,(if (and setr? setters)
101                                    `(,%getter-with-setter ,getr ,(caddr slot))
102                                    getr) )
103                     ,@(loop (cdr slots) (add1 i)))))))))))
104
105;;Types
106
107(define-type ver-part  (or number string symbol))
108(define-type ver-punc  char)
109(define-type ver       (struct semantic-version))
110
111;NOTE symbols are not preserved; the printname is used!
112(define-type verpro-part  (or number string symbol))
113(define-type verpro-punc  char)
114(define-type verpro-parts (list-of verpro-part))
115(define-type verpro-puncs (list-of verpro-punc))
116(define-type verpro       (struct semantic-version-protocol))
117
118(: list->version-protocol        ((list-of (or verpro-part verpro-punc)) --> verpro))
119(: version-protocol->list        (verpro --> (list-of (or verpro-part verpro-punc))))
120(: string->version-protocol      (string --> verpro))
121(: version-protocol->string      (verpro --> string))
122(: list->version/protocol        (verpro (list-of (or ver-part ver-punc)) -> ver))
123(: string->version/protocol      (verpro string -> ver))
124;;
125
126;semantic-version-protocol type
127
128;NOTE symbols are not preserved; the printname is used!
129(define (ver-part? x) (or (number? x) (string? x) (symbol? x)))
130(define (ver-punc? x) (char? x))
131
132;NOTE symbols are not preserved; the printname is used!
133(define (verpro-part? x) (or (number? x) (string? x) (symbol? x)))
134(define (verpro-punc? x) (char? x))
135
136(define semantic-version-protocol 'semantic-version-protocol)
137(define-record-type-variant semantic-version-protocol (unsafe unchecked inline)
138  (make-verpro cs ps)
139  verpro?
140  (cs verpro-parts)
141  (ps verpro-puncs))
142
143(define (make-empty-verpro) (make-verpro '() "")) ;#f ok
144
145(define (verprotyp? x) (and (verpro? x) (list? (verpro-parts x)) (string? (verpro-puncs x))))
146
147(define (copy-verpro v) (make-verpro (list-copy (verpro-parts v)) (string-copy (verpro-puncs v))))
148
149(define (ver-parts? l) (every ver-part? l))
150(define (ver-puncs? l) (every ver-punc? l))
151
152(define (verpro-parts? l) (every verpro-part? l))
153(define (verpro-puncs? l) (every verpro-punc? l))
154
155(define (badargmsg msg #!optional nam)
156  (string-append (or (and nam (->string nam)) "bad argument") " - " msg) )
157
158(define (badargerr loc obj msg #!optional nam)
159  (error loc (badargmsg msg nam) obj) )
160
161(define (check-parts loc x #!optional nam)
162  (unless (verpro-parts? x) (badargerr loc x "invalid semantic-version-protocol parts" nam))
163  x )
164
165(define (check-puncs loc x #!optional nam)
166  (unless (verpro-puncs? x) (badargerr loc x "invalid semantic-version-protocol puncs" nam))
167  x )
168
169;;
170
171;(list->version-protocol "major#" #\. 'minor# '(#\. point#) '(#\; "fix" (#\- reason$)))
172(define (list->version-protocol ls)
173  (make-empty-verpro) )
174
175;(version-protocol->list vp1) ;=> ("major#" #\. "minor#" '(#\. "point#") '(#\; "fix" (#\- "reason$")))
176(define (version-protocol->list verpro)
177  '() )
178
179;(define vp1 (string->version-protocol "major#.minor#[.point#][;fix[-reason$]]"))
180(define (string->version-protocol str)
181        (make-empty-verpro) )
182
183;(version-protocol->string vp1) ;=> "major#.minor#[.point#][;fix[-reason$]]"
184(define (version-protocol->string verpro)
185        "" )
186
187;(list->version/protocol vp1 '(1 #\. 2 #\. 3 #\; abc #\- because))
188(define (list->version/protocol verpro ls)
189        (make-version 0) )
190
191;(list->version/protocol vp1 "1.2.3;abc-because")
192(define (string->version/protocol verpro str)
193        (make-version 0) )
194
195) ;module semantic-version-protocol
Note: See TracBrowser for help on using the repository browser.