semver: more tests, some cleanup, simplify

diff --git a/extra/semver/semver-tests.factor b/extra/semver/semver-tests.factor
index 1c5366bfb7897faf59ad4b6f00544582189d9221..9083277486f6f6311b27540ab5e6e7b7e71b12b9 100644 (file)
--- a/extra/semver/semver-tests.factor
+++ b/extra/semver/semver-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2020 Doug Coleman.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math.order semver sequences
-sequences.extras tools.test ;
+USING: assocs kernel math.order random semver sequences
+sequences.extras sorting tools.test ;
 IN: semver.tests
 
 CONSTANT: semver-ranges {
@@ -130,33 +130,77 @@ CONSTANT: semver-gt-comparisons {
 }
 
 { t } [
-    semver-gt-comparisons
-    [ first2 [ parse-semver ] bi@ <=> ] zip-with
-    values [ +gt+ = ] all?
+    semver-gt-comparisons [ first2 semver<=> +gt+ eq? ] all?
 ] unit-test
 
 { t } [
-    semver-gt-comparisons
-    [ first2 swap [ parse-semver ] bi@ <=> ] zip-with
-    values [ +lt+ = ] all?
+    semver-gt-comparisons [ first2 swap semver<=> +lt+ eq? ] all?
 ] unit-test
 
-{ "1.2.4-dev.0" } [ "1.2.3" <semver> semver-inc-prepatch semver>string ] unit-test
-{ "1.2.4" } [ "1.2.3" <semver> semver-inc-patch semver>string ] unit-test
+{ "2.0.0" } [ "1.0.4-rc.1" >semver bump-major semver>string ] unit-test
+{ "2.0.0" } [ "1.1.0-rc.1" >semver bump-major semver>string ] unit-test
+{ "2.0.0" } [ "1.1.4-rc.1" >semver bump-major semver>string ] unit-test
+{ "2.0.0" } [ "1.2.3" >semver bump-major semver>string ] unit-test
+{ "1.0.0" } [ "1.0.0-rc.1" >semver bump-major semver>string ] unit-test
 
-{ "1.3.0-dev.0" } [ "1.2.3" <semver> semver-inc-preminor semver>string ] unit-test
-{ "1.3.0" } [ "1.2.3" <semver> semver-inc-minor semver>string ] unit-test
+{ "0.2.0" } [ "0.2.0-rc.1" >semver bump-minor semver>string ] unit-test
+{ "0.3.0" } [ "0.2.5-rc.1" >semver bump-minor semver>string ] unit-test
+{ "1.4.0" } [ "1.3.1" >semver bump-minor semver>string ] unit-test
 
-{ "2.0.0-dev.0" } [ "1.2.3" <semver> semver-inc-premajor semver>string ] unit-test
-{ "2.0.0-dev.1" } [ "1.2.3" <semver> semver-inc-premajor semver-inc-prerelease semver>string ] unit-test
-{ "2.0.0" } [ "1.2.3" <semver> semver-inc-major semver>string ] unit-test
+{ "1.3.3" } [ "1.3.2" >semver bump-patch semver>string ] unit-test
+{ "0.1.5" } [ "0.1.5-rc.2" >semver bump-patch semver>string ] unit-test
 
-{ "1.2.3-erg.0" } [ "1.2.3" <semver> "erg" semver-inc-prerelease-id semver>string ] unit-test
+{ "0.1.5-dev.0" } [ "0.1.4" >semver bump-prerelease semver>string ] unit-test
+{ "0.1.5-dev.1" } [ "0.1.5-dev.0" >semver bump-prerelease semver>string ] unit-test
 
-{ T{ semver f 2 7 2 "pre" "build" } } [ "2.7.2-pre+build" parse-semver ] unit-test
-{ T{ semver f 2 7 2 "pre" f } } [ "2.7.2-pre" parse-semver ] unit-test
-{ T{ semver f 2 7 2 f "build" } } [ "2.7.2+build" parse-semver ] unit-test
+{ "1.2.4-dev.0" } [ "1.2.3" >semver bump-prepatch semver>string ] unit-test
 
-[ "2.7.2.1+build" parse-semver ] [ malformed-semver? ] must-fail-with
-[ "2.7.2.+build" parse-semver ] [ malformed-semver? ] must-fail-with
-[ "2.7.2." parse-semver ] [ malformed-semver? ] must-fail-with
+{ "1.3.0-dev.0" } [ "1.2.3" >semver bump-preminor semver>string ] unit-test
+{ "1.3.0" } [ "1.2.3" >semver bump-minor semver>string ] unit-test
+
+{ "2.0.0-dev.0" } [ "1.2.3" >semver bump-premajor semver>string ] unit-test
+{ "2.0.0-dev.1" } [ "1.2.3" >semver bump-premajor bump-prerelease semver>string ] unit-test
+
+{ "1.2.3-erg.0" } [ "1.2.3-dev.0" >semver "erg" bump-prerelease-id semver>string ] unit-test
+{ "1.2.3-erg.1" } [ "1.2.3-erg.0" >semver "erg" bump-prerelease-id semver>string ] unit-test
+{ "1.2.4-erg.0" } [ "1.2.3" >semver "erg" bump-prerelease-id semver>string ] unit-test
+
+{ T{ semver f 2 7 2 "pre" "build" } } [ "2.7.2-pre+build" >semver ] unit-test
+{ T{ semver f 2 7 2 "pre" f } } [ "2.7.2-pre" >semver ] unit-test
+{ T{ semver f 2 7 2 f "build" } } [ "2.7.2+build" >semver ] unit-test
+
+[ "2.7.2.1+build" >semver ] [ malformed-semver? ] must-fail-with
+[ "2.7.2.+build" >semver ] [ malformed-semver? ] must-fail-with
+[ "2.7.2." >semver ] [ malformed-semver? ] must-fail-with
+[ "2.7." >semver ] [ malformed-semver? ] must-fail-with
+[ "2.7" >semver ] [ malformed-semver? ] must-fail-with
+[ "2." >semver ] [ malformed-semver? ] must-fail-with
+[ "2" >semver ] [ malformed-semver? ] must-fail-with
+
+{ +gt+ } [ "1.2.0-dev1" "0.12.1-dev2" semver<=> ] unit-test
+{ +lt+ } [ "1.2.0-dev12" "1.2.0-dev2" semver<=> ] unit-test
+{ +gt+ } [ "1.2.0-dev3" "1.2.0-dev21" semver<=> ] unit-test
+{ +lt+ } [ "1.9.0" "1.10.0" semver<=> ] unit-test
+{ +eq+ } [ "2.0.0-rc1" "2.0.0-rc1" semver<=> ] unit-test
+{ +lt+ } [ "1.0.0-rc1" "1.0.0" semver<=> ] unit-test
+{ +lt+ } [ "1.0.0-rc1" "1.0.0-rc2" semver<=> ] unit-test
+{ +lt+ } [ "1.0.0-rc.1" "1.0.0-rc.11" semver<=> ] unit-test
+{ +lt+ } [ "1.0.0-rc.2" "1.0.0-rc.11" semver<=> ] unit-test
+{ +eq+ } [ "1.0.0+foo" "1.0.0+bar" semver<=> ] unit-test
+{ +eq+ } [ "1.0.0" "1.0.0" semver<=> ] unit-test
+
+{ t } [
+    {
+        "1.0.0-alpha"
+        "1.0.0-alpha.1"
+        "1.0.0-alpha.beta"
+        "1.0.0-beta"
+        "1.0.0-beta.2"
+        "1.0.0-beta.11"
+        "1.0.0-rc.1"
+        "1.0.0"
+        "2.0.0"
+        "2.1.0"
+        "2.1.1"
+    } dup clone randomize [ semver<=> ] sort =
+] unit-test

diff --git a/extra/semver/semver.factor b/extra/semver/semver.factor
index a7352de3ad2ffae7a7af2ef241655e3188bd7106..0b4dbdf86e01ed39b181a94b23f7f4ff6f8ff4b1 100644 (file)
--- a/extra/semver/semver.factor
+++ b/extra/semver/semver.factor
@@ -1,62 +1,31 @@
 ! Copyright (C) 2020 Doug Coleman.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators combinators.smart io
-kernel math math.order math.parser multiline peg.ebnf sequences
-sequences.deep sequences.extras splitting strings ;
-IN: semver
-
-! caret - up to next major versions, aka only major version needs to match as long as minor/patch are >=
-! tilde - last number can increment, e.g. ~1.2 is <2.0, ~1.2.3 is <1.3
-
-: ?string>number ( str -- number/str )
-    dup string>number dup not -rot ? ;
 
-: split-numbers ( str -- seq )
-    [ { } ] [ "." split [ ?string>number ] map ] if-empty ;
+USING: accessors arrays assocs.extras combinators
+combinators.short-circuit combinators.smart io kernel math
+math.order math.parser multiline peg.ebnf sequences
+sequences.deep sequences.extras sorting.human splitting strings
+;
 
-: ?inc-string ( str -- str' )
-    string>number 1 + number>string ;
-
-SINGLETONS: major minor patch prerelease build prepatch preminor premajor ;
+IN: semver
 
 TUPLE: semver
-    { major integer initial: 0 }
-    { minor integer initial: 0 }
-    { patch integer initial: 0 }
-    { prerelease initial: "" }
-    { build initial: "" } ;
-
-ERROR: malformed-semver parts ;
-: check-semver-parts ( seq -- seq )
-    dup length 3 <= [ malformed-semver ] unless ;
-
-: parse-semver ( str -- semver )
-    "+" split1
-    [ "-" split1 ] dip
-    [ "." split [ string>number ] map check-semver-parts first3 ] 2dip
-    semver boa ;
-
-: <semver> ( str -- semver ) parse-semver ; inline
-
-: first-semver-slot ( semver -- class )
-    {
-        { [ dup major>> 0 > ] [ drop major ] }
-        { [ dup minor>> 0 > ] [ drop minor ] }
-        { [ dup patch>> 0 > ] [ drop patch ] }
-        { [ dup prerelease>> length 0 > ] [ drop prerelease ] }
-        { [ dup build>> length 0 > ] [ drop build ] }
-        [ drop major ]
-    } cond ;
-
-: last-semver-slot ( semver -- class )
-    {
-        { [ dup build>> length 0 > ] [ drop build ] }
-        { [ dup prerelease>> length 0 > ] [ drop prerelease ] }
-        { [ dup patch>> 0 > ] [ drop patch ] }
-        { [ dup minor>> 0 > ] [ drop minor ] }
-        { [ dup major>> 0 > ] [ drop major ] }
-        [ drop major ]
-    } cond ;
+    { major integer }
+    { minor integer }
+    { patch integer }
+    prerelease
+    build ;
+
+ERROR: malformed-semver obj ;
+
+GENERIC: >semver ( obj -- semver )
+M: semver >semver ;
+M: string >semver
+    dup "+" split1 [ "-" split1 ] dip [
+        "." split [ string>number ] map
+        dup { [ length 3 = ] [ [ integer? ] all? ] } 1&&
+        [ nip first3 ] [ drop malformed-semver ] if
+    ] 2dip semver boa ;
 
 : semver>string ( semver -- string )
     [
@@ -64,157 +33,151 @@ ERROR: malformed-semver parts ;
             [ major>> number>string "." ]
             [ minor>> number>string "." ]
             [ patch>> number>string ]
-            [ prerelease>> [ "" "" ] [ "-" swap ] if-empty ]
-            [ build>> [ "" "" ] [ "+" swap ] if-empty ]
+            [ prerelease>> [ f f ] [ "-" swap ] if-empty ]
+            [ build>> [ f f ] [ "+" swap ] if-empty ]
         } cleave
     ] "" append-outputs-as ;
 
 : semver. ( semver -- )
     semver>string print ;
 
-: semver-inc-major ( semver -- semver )
-    dup prerelease>> [
+: bump-major ( semver -- semver )
+    f >>build dup {
+        [ prerelease>> empty? ]
+        [ minor>> zero? not ]
+        [ patch>> zero? not ]
+    } 1|| [
         [ 1 + ] change-major
         0 >>minor
         0 >>patch
-        "" >>prerelease
-        "" >>build
-    ] [
-        drop
-        "" >>prerelease
-        "" >>build
-    ] if-empty ;
+    ] when f >>prerelease ;
 
-: semver-inc-minor ( semver -- semver )
-    dup prerelease>> [
+: bump-minor ( semver -- semver )
+    f >>build dup {
+        [ prerelease>> empty? ]
+        [ patch>> zero? not ]
+    } 1|| [
         [ 1 + ] change-minor
         0 >>patch
-        "" >>prerelease
-        "" >>build
-    ] [
-        drop
-        "" >>prerelease
-        "" >>build
-    ] if-empty ;
+    ] when f >>prerelease ;
 
-: semver-inc-patch ( semver -- semver )
-    dup prerelease>> [
+: bump-patch ( semver -- semver )
+    f >>build dup prerelease>> empty? [
         [ 1 + ] change-patch
-        "" >>prerelease
-        "" >>build
-    ] [
-        drop
-        "" >>prerelease
-        "" >>build
-    ] if-empty ;
-
-: semver-inc-prerelease ( semver -- semver )
-    dup prerelease>> [
-        "0"
-    ] [
-        "." split
-        dup [ string>number ] find-last [
-            over [ ?inc-string ] change-nth
-            "." join
-        ] [
-            2drop "dev.0"
-        ] if
-    ] if-empty >>prerelease
-    "" >>build ;
+    ] when f >>prerelease ;
 
-: semver-inc-prerelease-id ( semver id -- semver )
+: bump-prerelease-id ( semver id -- semver )
     over prerelease>> [
-        "0" "." glue
+        [ bump-patch ] dip ".0" append
     ] [
         2dup swap head? [
             "." split
             dup [ string>number ] find-last [
-                over [ ?inc-string ] change-nth
+                over [ string>number 1 + number>string ] change-nth
                 "." join nip
             ] [
-                2drop "0" "." glue
+                2drop ".0" append
             ] if
         ] [
-            drop "0" "." glue
+            drop ".0" append
         ] if
     ] if-empty >>prerelease
-    "" >>build ;
+    f >>build ;
+
+: bump-prerelease ( semver -- semver )
+    "dev" bump-prerelease-id ;
 
-: semver-inc-prepatch ( semver -- semver )
+: bump-prepatch ( semver -- semver )
     [ 1 + ] change-patch
     "dev.0" >>prerelease
-    "" >>build ;
+    f >>build ;
 
-: semver-inc-preminor ( semver -- semver )
+: bump-preminor ( semver -- semver )
     [ 1 + ] change-minor
     0 >>patch
     "dev.0" >>prerelease
-    "" >>build ;
+    f >>build ;
 
-: semver-inc-premajor ( semver -- semver )
+: bump-premajor ( semver -- semver )
     [ 1 + ] change-major
     0 >>minor
     0 >>patch
     "dev.0" >>prerelease
-    "" >>build ;
-
-GENERIC: lower-range ( obj -- str )
+    f >>build ;
 
-M: string lower-range ( obj -- semver )
-    parse-semver semver>string ">=" prepend ;
+: lower-range ( semver -- str )
+    semver>string ">=" prepend ;
 
-M: array lower-range ( obj -- semver )
-    parse-semver semver>string ">=" prepend ;
+: upper-range ( semver -- str )
+    semver>string "<=" prepend ;
 
-GENERIC: upper-range ( obj -- str )
+<PRIVATE
 
-M: string upper-range ( obj -- semver )
-    parse-semver semver>string "<=" prepend ;
+: major<=> ( semvar1 semvar2 -- <=> ) [ major>> ] compare ; inline
 
-M: array upper-range ( obj -- semver )
-    parse-semver semver>string "<=" prepend ;
+: minor<=> ( semvar1 semvar2 -- <=> ) [ minor>> ] compare ; inline
 
-: major-minor-patch-compare ( s1 s2 -- <=> part )
-    2dup [ major>> ] compare
-    dup +eq+ eq? [
-        drop 2dup [ minor>> ] compare
-        dup +eq+ eq? [
-            drop [ patch>> ] compare patch
-        ] [
-            2nip minor
-        ] if
-    ] [
-        2nip major
-    ] if ; inline
+: patch<=> ( semvar1 semvar2 -- <=> ) [ patch>> ] compare ; inline
 
-: compare-prelreases ( semver1 semver2 -- <=> )
-    [ prerelease>> ] bi@ over empty? [
-        nip empty? +eq+ +gt+ ?
-    ] [
-        dup empty? [ 2drop +lt+ ] [
-            [ split-numbers ] bi@
-            f pad-longest zip [
-                first2
-                {
+: prerelease<=> ( semver1 semver2 -- <=> )
+    [ prerelease>> ] bi@ {
+        { [ over empty? ] [ nip empty? +eq+ +gt+ ? ] }
+        { [ dup empty? ] [ 2drop +lt+ ] }
+        [
+            [ "." split [ [ string>number ] keep or ] map ] bi@
+            zip-longest [
+                first2 {
+                    { [ over not ] [ 2drop +lt+ ] }
+                    { [ dup not ] [ 2drop +gt+ ] }
                     { [ 2dup [ integer? ] both? ] [ <=> ] }
                     { [ 2dup [ string? ] both? ] [ <=> ] }
                     { [ over integer? ] [ 2drop +lt+ ] }
                     { [ dup integer? ] [ 2drop +gt+ ] }
-                    { [ over f = ] [ 2drop +lt+ ] }
-                    { [ dup f = ] [ 2drop +gt+ ] }
                     [ 2drop +eq+ ]
-                } cond
-            ] [
-                +eq+ = not
-            ] find-pred 2drop
-        ] if
-    ] if ;
+                } cond dup +eq+ eq? [ drop f ] when
+            ] map-find drop +eq+ or
+        ]
+    } cond ; inline
+
+PRIVATE>
 
 M: semver <=>
-    2dup major-minor-patch-compare drop
-    dup +eq+ = [ drop compare-prelreases ] [ 2nip ] if ;
+    2dup major<=> dup +eq+ eq? [
+        drop 2dup minor<=> dup +eq+ eq? [
+            drop 2dup patch<=> dup +eq+ eq? [
+                drop prerelease<=>
+            ] [ 2nip ] if
+        ] [ 2nip ] if
+    ] [ 2nip ] if ;
 
-EBNF: parse-range [=[
+: semver<=> ( obj1 obj2 -- <=> ) [ >semver ] compare ; inline
+
+! caret - up to next major versions, aka only major version needs to match as long as minor/patch are >=
+! tilde - last number can increment, e.g. ~1.2 is <2.0, ~1.2.3 is <1.3
+
+SINGLETONS: major minor patch prerelease build prepatch preminor premajor ;
+
+: first-semver-slot ( semver -- class )
+    {
+        { [ dup major>> 0 > ] [ drop major ] }
+        { [ dup minor>> 0 > ] [ drop minor ] }
+        { [ dup patch>> 0 > ] [ drop patch ] }
+        { [ dup prerelease>> length 0 > ] [ drop prerelease ] }
+        { [ dup build>> length 0 > ] [ drop build ] }
+        [ drop major ]
+    } cond ;
+
+: last-semver-slot ( semver -- class )
+    {
+        { [ dup build>> length 0 > ] [ drop build ] }
+        { [ dup prerelease>> length 0 > ] [ drop prerelease ] }
+        { [ dup patch>> 0 > ] [ drop patch ] }
+        { [ dup minor>> 0 > ] [ drop minor ] }
+        { [ dup major>> 0 > ] [ drop major ] }
+        [ drop major ]
+    } cond ;
+
+EBNF: parse-semver-range [=[
     logical-or = [\s\t]*~  '||'  [\s\t]*~
     range      = hyphen | simple ( [\s\t]*~ simple )*  => [[ first2 swap prefix ]]
     hyphen     = partial:p1 [\s\t]*~ '-':t  [\s\t]*~  partial:p2 => [[ p1 t  p2 3array ]]
@@ -232,4 +195,3 @@ EBNF: parse-range [=[
     part       = nr | [-0-9A-Za-z]+ => [[ >string ]]
     range-set  = range? ( logical-or range? )* => [[ first2 swap prefix ]]
 ]=]
-