Loris  Check-in [17bd3b2314]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Rework the version library again. All exports use strings for version numbers. Remove version juggling outside of the version library. There are now 3 exported procedures, VERSION, FEATURE-VERSION and ASSERT. VERSION is called without arguments and will evaluate to the Loris library version. (version) -> "2.1.0-devel" FEATURE-VERSION may be called with zero or one argument. Called with no arguments, it evaluates to the Loris MAJOR.MINOR version. If an argument is supplied, it will be used instead of the Loris library version string. (feature-version) -> "2.1" (feature-version "1.2.3-alpha+build.2" -> "1.2" ASSERT takes one argument, interprets it as a version number string, and throws an error iff a program written for that specific version of the Loris library will not be compatible with the current Loris version. Otherwise, the program is assumed to be compatible with the current Loris version, and the current Loris library is returned. In the follow examples, the Loris version is assumed to be "2.1.0-devel.2" (assert "2.1.0-alfa") -> "2.1.0-devel" (assert "2.1.0-devel") -> "2.1.0-devel" (assert "2.1.0-devel.2") -> ERROR (assert "2.1.0") -> ERROR (assert "1.8.4") -> ERROR (assert "2.0.0") -> ERROR (assert "2.10.0") -> "2.1.0-devel"
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:17bd3b231467bb6e28a161d7a0ea148341e86a93
User & Date: jesper 2016-04-18 09:34:33
Context
2016-04-18
09:36
Let's not tag 2.0.0 just yet, but wait until the API is finalised. Unbump. The v2.0.0 tag has also been removed from the repo [b1ab17dad2]. check-in: 5d78f9cc74 user: jesper tags: trunk
09:34
Rework the version library again. All exports use strings for version numbers. Remove version juggling outside of the version library. There are now 3 exported procedures, VERSION, FEATURE-VERSION and ASSERT. VERSION is called without arguments and will evaluate to the Loris library version. (version) -> "2.1.0-devel" FEATURE-VERSION may be called with zero or one argument. Called with no arguments, it evaluates to the Loris MAJOR.MINOR version. If an argument is supplied, it will be used instead of the Loris library version string. (feature-version) -> "2.1" (feature-version "1.2.3-alpha+build.2" -> "1.2" ASSERT takes one argument, interprets it as a version number string, and throws an error iff a program written for that specific version of the Loris library will not be compatible with the current Loris version. Otherwise, the program is assumed to be compatible with the current Loris version, and the current Loris library is returned. In the follow examples, the Loris version is assumed to be "2.1.0-devel.2" (assert "2.1.0-alfa") -> "2.1.0-devel" (assert "2.1.0-devel") -> "2.1.0-devel" (assert "2.1.0-devel.2") -> ERROR (assert "2.1.0") -> ERROR (assert "1.8.4") -> ERROR (assert "2.0.0") -> ERROR (assert "2.10.0") -> "2.1.0-devel" check-in: 17bd3b2314 user: jesper tags: trunk
2016-04-16
12:09
Document this confusing procedure check-in: efb39c9699 user: jesper tags: trunk
Changes

Changes to config.scm.

74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
                                                         (conf-path (car mappings)))))))
           (else
            (loop (cdr mappings) result))))))

    (define (init display-name version . argtail)
      (let ((defaults (if (not (null? argtail)) (car argtail) '())))
        (platform:init (string-symbol-format display-name))
        (let* ((version-tokens (version:tokenise-semantic-version version))
               (loris `((program (display-name . ,display-name)
                                 (version . ,version)
                                 (major . ,(car version-tokens))
                                 (minor . ,(cadr version-tokens))
                                 (revision . ,(car (cddr version-tokens))))))
               (sys-conf (let ((fn (platform:ref 'system-config-file)))
                           (if fn (read-ini-file fn) '())))
               (user-conf (let ((fn (platform:ref 'user-config-file)))
                            (if fn (read-ini-file fn) '())))
               (env-conf (env->conf (get-environment-variables))))
          (set! ref (make-configuration loris defaults env-conf sys-conf user-conf)))))))







<
|
|
<
<
<






74
75
76
77
78
79
80

81
82



83
84
85
86
87
88
                                                         (conf-path (car mappings)))))))
           (else
            (loop (cdr mappings) result))))))

    (define (init display-name version . argtail)
      (let ((defaults (if (not (null? argtail)) (car argtail) '())))
        (platform:init (string-symbol-format display-name))

        (let* ((loris `((program (display-name . ,display-name)
                                 (version . ,version))))



               (sys-conf (let ((fn (platform:ref 'system-config-file)))
                           (if fn (read-ini-file fn) '())))
               (user-conf (let ((fn (platform:ref 'user-config-file)))
                            (if fn (read-ini-file fn) '())))
               (env-conf (env->conf (get-environment-variables))))
          (set! ref (make-configuration loris defaults env-conf sys-conf user-conf)))))))

Changes to platform.scm.

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
...
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158

          ;; reexport from files module
          make-absolute-pathname absolute-pathname? normalize-pathname delete-file)
  (begin
    (define ref 'not-initialised)
    ;; Do not set your program name below. Instead, use (config:init). See templates/bootstrap.scm.
    (define program-name (make-parameter (car (command-line))))
    (define program-version (version:full-semantic))
    (define command-line-parameters (cdr (command-line)))
    (define (feature-find needles)
      (let ((needles (if (not (list? needles)) (list needles) needles))
            (available-features (features)))
        (find (lambda (needle)
                (find (lambda (feature)
                        (equal? needle feature))
................................................................................
                                 (list (get-environment-variable (conc program-env-var-name "_RC"))
                                       (nix/win
                                        (conc user-data-dir "/config")
                                        (conc user-data-dir "/settings.ini"))
                                       user-config-default-filename))))
             (cache-dir (platform-dir-slashes (conc user-data-dir "/cache")))
             (platform-values `((program-filename . ,program-filename)
                                (loris-version . ,(version:full-semantic))
                                (loris-short-version . ,(version:semantic))
                                (command-line-parameters ,command-line-parameters)
                                (home-dir . ,home-dir)
                                (etc-dir . ,etc-dir)
                                (user-data-dir . ,user-data-dir)
                                (user-config-dir . ,user-conf-dir)
                                (user-config-file . ,user-config-file)
                                (user-config-default-filename . ,user-config-default-filename)







<







 







|
|







45
46
47
48
49
50
51

52
53
54
55
56
57
58
...
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

          ;; reexport from files module
          make-absolute-pathname absolute-pathname? normalize-pathname delete-file)
  (begin
    (define ref 'not-initialised)
    ;; Do not set your program name below. Instead, use (config:init). See templates/bootstrap.scm.
    (define program-name (make-parameter (car (command-line))))

    (define command-line-parameters (cdr (command-line)))
    (define (feature-find needles)
      (let ((needles (if (not (list? needles)) (list needles) needles))
            (available-features (features)))
        (find (lambda (needle)
                (find (lambda (feature)
                        (equal? needle feature))
................................................................................
                                 (list (get-environment-variable (conc program-env-var-name "_RC"))
                                       (nix/win
                                        (conc user-data-dir "/config")
                                        (conc user-data-dir "/settings.ini"))
                                       user-config-default-filename))))
             (cache-dir (platform-dir-slashes (conc user-data-dir "/cache")))
             (platform-values `((program-filename . ,program-filename)
                                (loris-version . ,(version:version))
                                (loris-feature-version . ,(version:feature-version))
                                (command-line-parameters ,command-line-parameters)
                                (home-dir . ,home-dir)
                                (etc-dir . ,etc-dir)
                                (user-data-dir . ,user-data-dir)
                                (user-config-dir . ,user-conf-dir)
                                (user-config-file . ,user-config-file)
                                (user-config-default-filename . ,user-config-default-filename)

Changes to templates/bootstrap.scm.

13
14
15
16
17
18
19
20
21
;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

(use r7rs)

(include "loris/init.scm")
(include "loader.scm")

(platform:assert 2 0 0)
(config:init "My Program" "0.0.0")







|

13
14
15
16
17
18
19
20
21
;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

(use r7rs)

(include "loris/init.scm")
(include "loader.scm")

(platform:assert "2.1.0")
(config:init "My Program" "0.0.0")

Changes to version.scm.

23
24
25
26
27
28
29
30
31
32

33
34
35
36
37
38
39
40
41
42
43









44
45
46
47
48

49

50





51
52





























53

54
55
56








57
58

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107





108
109
110
111
112
113
114
115
116
117

118
119
120
121
122
123
124
125
126
127
128
129
130
131

132
133
134
135
136
(define-library (loris version)
  (import (scheme base)
          (scheme case-lambda)
          (loris convenience)
          (srfi 1)
          (srfi 13)
          (srfi 14))
  (export semantic full-semantic assert tokenise-semantic-version)
  (begin
    (define version (list 2 1 0	        ; version:      numeric (major, minor, patch)

                          "devel"       ; pre-release:  #f or alphanumeric string (no hyphens!)
                          #f))          ; metadata:     #f or alphanumeric string (no hyphens!)

    (define (tokenise-semantic-version v)
      (if (not v) '()
          (let* ((v (string-tokenize v char-set:letter+digit)))
            (map (lambda (o)
                   (let ((v (string->number o)))
                     (if v v o)))
                 v))))










    (define make-semantic
      (case-lambda
        ((j n) (string-append (number->string j) "." (number->string n)))
        ((j n p) (string-append (make-semantic j n) "." (number->string p)))
        ((j n p r) (string-append (make-semantic j n p) (if r (string-append "-" r) "")))

        ((j n p r m) (string-append (make-semantic j n p r) (if m (string-append "+" m) "")))))

      





    (define (semantic)
      (make-semantic (car version) (cadr version)))































    (define (full-semantic)
      (apply make-semantic version))









    (define version-number=? equal?)
    (define semantic-version=? equal?)	; works since equal? is list recursive as it is


    (define (version-number</compare-two a b)
      (cond ((and (number? a) (not (number? b))) #t)
            ((and (not (number? a)) (number? b)) #f)
            ((and (number? a) (number? b)) (< a b))
            (else (string< a b))))

    ;; This procedure is unaware of how (list 1 0 0 "beta") is lower
    ;; than (list 1 0 0) according to semver.org. Therefore, it should
    ;; not be exposed outside of this library.
    ;;
    ;; The procedure compatible? uses this procedure (through
    ;; semantic-version<) to compare the cdr of the full semantic
    ;; version. However, this is done only after the eventuality of
    ;; only one of the two versions having a pre-release tag has
    ;; been handled.
    (define (semantic-version</compare-two a-list b-list)
      (let check ((a a-list)
                  (b b-list))
        (cond ((null? b) #f)
              ((null? a) #t)
              ((version-number< (car a) (car b)) #t)
              ((version-number< (car b) (car a)) #f)
              (else (check (cdr a) (cdr b))))))

    (define version-number< (make-chain-pred version-number</compare-two))
    (define semantic-version< (make-chain-pred semantic-version</compare-two))

    (define (compatible? wanted actual)
      ;; Unparse any prerelease tags present and append them to (list
      ;; MINOR PATCH).  We're not interested in the MAJOR version,
      ;; since checking for compatiblity simply means applying equal?
      ;; to them.
      (let ((wanted-tail (append (cdr (take wanted 3))
                                 (if (< 3 (length wanted))
                                     (tokenise-semantic-version (fourth wanted))
                                     '())))
            (actual-tail (append (cdr (take actual 3))
                                 (if (< 3 (length actual))
                                     (tokenise-semantic-version (fourth actual))
                                     '()))))
        ;; Asking for 1.2.3-devel and getting 1.2.3 is fine
        (or (and (equal? (take wanted 3) (take actual 3))
                 (= 3 (length actual))
                 (< 3 (length wanted)))
            ;; Asking for 1.2.3 and getting 1.2.3-devel is not fine
            (and (nand (equal? (take wanted 3) (take actual 3))

                       (= 3 (length wanted))
                       (< 3 (length actual)))





                 (semantic-version=? (car wanted) (car actual))
                 ;; Having excluded the above cases, just check that
                 ;; what is provided isn't lower than what is being
                 ;; asked for.
                 (not (semantic-version< actual-tail wanted-tail))))))

    ;; Given a semantic version number, throw an error iff the currently
    ;; running version is incompatible with the one given.
    ;;
    ;; With semantic versioning as it is, the following requirements are used:

    ;;
    ;;    The requested major version must be equal to ours.
    ;;    The requested minor version must be equal to or higher than ours.
    ;;    If the requested major and minor versions are equal to ours,
    ;;        the requested revision must be equal to or higher than ours.
    ;;
    ;; Returns two values if all tests were passed. The primary value is
    ;; our version in list form.  The secondary value is our version in
    ;; string form.
    ;;
    ;; This procedure must function before platform:init has been evaluated.
    (define (assert . requested-version)
      (let* ((current-version-string (apply make-semantic version))
             (requested-version-string (apply make-semantic requested-version)))

        (if (compatible? requested-version version)
            (values version current-version-string)
            (error (string-append "Incompatible Loris version. Program requested "
                                  requested-version-string
                                  " but is running on " current-version-string)))))))







|

<
>
|
|
|
|
|
|
|
|
|
<

>
>
>
>
>
>
>
>
>
|


|
|
>
|
>
|
>
>
>
>
>
|
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
|
|

>
>
>
>
>
>
>
>

|
>







|
|
|
<
<
<
<
<
<
|









|

|
|
|
<
<
<
<
|
<
<
<
<
<
<
|
<
<
<
<
>
|
<
>
>
>
>
>
|
<
<
<
|




<
>

<
<
<
<
<
<
<
<
<

|
|
<
>
|
|



23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121






122
123
124
125
126
127
128
129
130
131
132
133
134
135
136




137






138




139
140

141
142
143
144
145
146



147
148
149
150
151

152
153









154
155
156

157
158
159
160
161
162
(define-library (loris version)
  (import (scheme base)
          (scheme case-lambda)
          (loris convenience)
          (srfi 1)
          (srfi 13)
          (srfi 14))
  (export version feature-version assert)
  (begin


    ;; Set the loris version number here
    (define loris-version (list 2 1 0 "devel" ""))
    
    ;; Some assumptions are made of the type of the values stored in
    ;; this record. j, n and p are expected to be numbers, while pr
    ;; and md are expected to be non-empty alphanumeric+hyphen strings
    ;; or #f. Anything else will lead to errors or unexpected
    ;; behaviour. These restrictions are in accordance with the
    ;; Semantic Version specification 2.0.0.



    ;; Set up some accessors for readability.
    (define (curry-list-ref n) (lambda (lst) (list-ref lst n)))
    (define major (curry-list-ref 0))
    (define minor (curry-list-ref 1))
    (define patch (curry-list-ref 2))
    (define pre-release (curry-list-ref 3))
    (define metadata (curry-list-ref 4))

    (define make-semantic-string
      (case-lambda
        ((j n) (string-append (number->string j) "." (number->string n)))
        ((j n p) (string-append (make-semantic-string j n) "." (number->string p)))
        ((j n p r) (string-append (make-semantic-string j n p)
                                  (if (not (string-null? r)) (string-append "-" r) "")))
        ((j n p r m) (string-append (make-semantic-string j n p r)
                                    (if (not (string-null? m)) (string-append "+" m) "")))))

    (define (tokenise-chain v)
      (let* ((v (string-tokenize v (char-set-adjoin char-set:letter+digit #\-)))
             (maybe-number (lambda (o) (let ((v (string->number o))) (if v v o)))))
        (map maybe-number v)))

    (define (string->version str)

      ;; Loop state machine until out of version string. States:
      ;; 'version	Parse numbers separated by dots, until #\-,
      ;; 		#\+ or end of string.
      ;; 'pre-release	Parse string until #\+ or end of string.
      ;; 'metadata	Parse string until end of string.
      (let loop ((rest (string->list str))
                 (state 'version)
                 (this-value '())
                 (result '()))
        (cond ((null? rest)
               (let ((v (append (reverse (cons this-value result)) (circular-list '()))))
                 (list (string->number (list->string (reverse (major v))))
                       (string->number (list->string (reverse (minor v))))
                       (string->number (list->string (reverse (patch v))))
                       (list->string (reverse (pre-release v)))
                       (list->string (reverse (metadata v))))))
              ((and (equal? state 'version)
                    (char=? #\. (car rest)))
               (loop (cdr rest) state '() (cons this-value result)))
              ((and (equal? state 'version)
                    (char=? #\- (car rest)))
               (loop (cdr rest) 'pre-release '() (cons this-value result)))
              ((and (equal? state 'version)
                    (char=? #\+ (car rest)))
               (loop (cdr rest) 'metadata '() (append (list '() this-value) result)))
              ((and (equal? state 'pre-release)
                    (char=? #\+ (car rest)))
               (loop (cdr rest) 'metadata '() (cons this-value result)))
              (else (loop (cdr rest) state (cons (car rest) this-value) result)))))

    ;; Evaluates to a string of the full loris library version.
    (define (version)
      (apply make-semantic-string loris-version))

    ;; Evaluates to a string with MAJOR.MINOR version numbers of the
    ;; supplied (string) version. If evaluated without an argument,
    ;; returns the MAJOR.MINOR of the loris library.
    (define feature-version
      (case-lambda
        (() (make-semantic-string (major loris-version) (minor loris-version)))
        ((v) (apply make-semantic-string (string->version v)))))

    (define version-number=? equal?)
    (define semantic-chain=? equal?)	; works since equal? is list recursive as it is
    (define semantic-version=? equal?)	; as above

    (define (version-number</compare-two a b)
      (cond ((and (number? a) (not (number? b))) #t)
            ((and (not (number? a)) (number? b)) #f)
            ((and (number? a) (number? b)) (< a b))
            (else (string< a b))))

    ;; This procedure is unaware of how (list 1 0 0 "beta") is a lower
    ;; version number than (list 1 0 0) according to the semantic
    ;; versioning spec.






    (define (semantic-chain</compare-two a-list b-list)
      (let check ((a a-list)
                  (b b-list))
        (cond ((null? b) #f)
              ((null? a) #t)
              ((version-number< (car a) (car b)) #t)
              ((version-number< (car b) (car a)) #f)
              (else (check (cdr a) (cdr b))))))

    (define version-number< (make-chain-pred version-number</compare-two))
    (define semantic-chain< (make-chain-pred semantic-chain</compare-two))

    (define (semantic-version< wanted actual)
      (let ((pre-release? (lambda (v) (not (string-null? (pre-release v)))))
            (version->chain (lambda (v) (append (take v 3) (tokenise-chain (pre-release v))))))




        (cond ((semantic-version=? wanted actual) #f)






              ((and (equal? (take wanted 3) (take actual 3))




                    (xor (pre-release? wanted) (pre-release? actual)))
               (pre-release? wanted))

              (else
               (semantic-chain< (version->chain wanted) (version->chain actual))))))

    (define (compatible? written-for running-against)
      (and (equal? (major written-for) (major running-against))
           (or (semantic-version=? written-for running-against)



               (semantic-version< written-for running-against))))

    ;; Given a semantic version number, throw an error iff the currently
    ;; running version is incompatible with the one given.
    ;;

    ;; Returns the current loris version string iff compatible.
    ;;









    ;; This procedure must function before platform:init has been evaluated.
    (define (assert requested-version-string)
      (let* ((current-version-string (apply make-semantic-string loris-version))

             (requested-version (string->version requested-version-string)))
        (if (compatible? requested-version loris-version)
            current-version-string
            (error (string-append "Incompatible Loris version. Program requested "
                                  requested-version-string
                                  " but is running on " current-version-string)))))))