extra/semver/semver.factor

   1 ! Copyright (C) 2020 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors arrays assocs.extras combinators
   5 combinators.short-circuit combinators.smart io kernel math
   6 math.order math.parser multiline peg.ebnf sequences
   7 sequences.deep sequences.extras splitting strings ;
   8
   9 IN: semver
  10
  11 TUPLE: semver
  12     { major integer }
  13     { minor integer }
  14     { patch integer }
  15     prerelease
  16     build ;
  17
  18 ERROR: malformed-semver obj ;
  19
  20 GENERIC: >semver ( obj -- semver )
  21 M: semver >semver ;
  22 M: string >semver
  23     dup "+" split1 [ "-" split1 ] dip [
  24         "." split [ string>number ] map
  25         dup { [ length 3 = ] [ [ integer? ] all? ] } 1&&
  26         [ nip first3 ] [ drop malformed-semver ] if
  27     ] 2dip semver boa ;
  28
  29 : semver>string ( semver -- string )
  30     [
  31         {
  32             [ major>> number>string "." ]
  33             [ minor>> number>string "." ]
  34             [ patch>> number>string ]
  35             [ prerelease>> [ f f ] [ "-" swap ] if-empty ]
  36             [ build>> [ f f ] [ "+" swap ] if-empty ]
  37         } cleave
  38     ] "" append-outputs-as ;
  39
  40 : semver. ( semver -- )
  41     semver>string print ;
  42
  43 : bump-major ( semver -- semver )
  44     f >>build dup {
  45         [ prerelease>> empty? ]
  46         [ minor>> zero? not ]
  47         [ patch>> zero? not ]
  48     } 1|| [
  49         [ 1 + ] change-major
  50         0 >>minor
  51         0 >>patch
  52     ] when f >>prerelease ;
  53
  54 : bump-minor ( semver -- semver )
  55     f >>build dup {
  56         [ prerelease>> empty? ]
  57         [ patch>> zero? not ]
  58     } 1|| [
  59         [ 1 + ] change-minor
  60         0 >>patch
  61     ] when f >>prerelease ;
  62
  63 : bump-patch ( semver -- semver )
  64     f >>build dup prerelease>> empty? [
  65         [ 1 + ] change-patch
  66     ] when f >>prerelease ;
  67
  68 : bump-prerelease ( semver id -- semver )
  69     over prerelease>> [
  70         [ bump-patch ] dip [ "0" ] [ ".0" append ] if-empty
  71     ] [
  72         2dup swap head? [
  73             "." split
  74             dup [ string>number ] find-last [
  75                 over [ string>number 1 + number>string ] change-nth
  76                 "." join nip
  77             ] [
  78                 2drop [ "0" ] [ ".0" append ] if-empty
  79             ] if
  80         ] [
  81             drop [ "0" ] [ ".0" append ] if-empty
  82         ] if
  83     ] if-empty >>prerelease f >>build ;
  84
  85 : bump-dev ( semver -- semver ) f bump-prerelease ;
  86
  87 : bump-alpha ( semver -- semver ) "alpha" bump-prerelease ;
  88
  89 : bump-beta ( semver -- semver ) "beta" bump-prerelease ;
  90
  91 : bump-rc ( semver -- semver ) "rc" bump-prerelease ;
  92
  93 : bump-premajor ( semver -- semver )
  94     [ 1 + ] change-major 0 >>minor 0 >>patch "0" >>prerelease f >>build ;
  95
  96 : bump-preminor ( semver -- semver )
  97     [ 1 + ] change-minor 0 >>patch "0" >>prerelease f >>build ;
  98
  99 : bump-prepatch ( semver -- semver )
 100     [ 1 + ] change-patch "0" >>prerelease f >>build ;
 101
 102 : lower-range ( semver -- str )
 103     semver>string ">=" prepend ;
 104
 105 : upper-range ( semver -- str )
 106     semver>string "<=" prepend ;
 107
 108 <PRIVATE
 109
 110 : major<=> ( semvar1 semvar2 -- <=> ) [ major>> ] compare ; inline
 111
 112 : minor<=> ( semvar1 semvar2 -- <=> ) [ minor>> ] compare ; inline
 113
 114 : patch<=> ( semvar1 semvar2 -- <=> ) [ patch>> ] compare ; inline
 115
 116 : prerelease<=> ( semver1 semver2 -- <=> )
 117     [ prerelease>> ] bi@ {
 118         { [ over empty? ] [ nip empty? +eq+ +gt+ ? ] }
 119         { [ dup empty? ] [ 2drop +lt+ ] }
 120         [
 121             [ "." split [ [ string>number ] keep or ] map ] bi@
 122             zip-longest [
 123                 first2 {
 124                     { [ over not ] [ 2drop +lt+ ] }
 125                     { [ dup not ] [ 2drop +gt+ ] }
 126                     { [ 2dup [ integer? ] both? ] [ <=> ] }
 127                     { [ 2dup [ string? ] both? ] [ <=> ] }
 128                     { [ over integer? ] [ 2drop +lt+ ] }
 129                     { [ dup integer? ] [ 2drop +gt+ ] }
 130                     [ 2drop +eq+ ]
 131                 } cond dup +eq+ eq? [ drop f ] when
 132             ] map-find drop +eq+ or
 133         ]
 134     } cond ; inline
 135
 136 PRIVATE>
 137
 138 M: semver <=>
 139     2dup major<=> dup +eq+ eq? [
 140         drop 2dup minor<=> dup +eq+ eq? [
 141             drop 2dup patch<=> dup +eq+ eq? [
 142                 drop prerelease<=>
 143             ] [ 2nip ] if
 144         ] [ 2nip ] if
 145     ] [ 2nip ] if ;
 146
 147 : semver<=> ( obj1 obj2 -- <=> ) [ >semver ] compare ; inline
 148
 149 ! caret - up to next major versions, aka only major version needs to match as long as minor/patch are >=
 150 ! tilde - last number can increment, e.g. ~1.2 is <2.0, ~1.2.3 is <1.3
 151
 152 SINGLETONS: major minor patch prerelease build prepatch preminor premajor ;
 153
 154 : first-semver-slot ( semver -- class )
 155     {
 156         { [ dup major>> 0 > ] [ drop major ] }
 157         { [ dup minor>> 0 > ] [ drop minor ] }
 158         { [ dup patch>> 0 > ] [ drop patch ] }
 159         { [ dup prerelease>> length 0 > ] [ drop prerelease ] }
 160         { [ dup build>> length 0 > ] [ drop build ] }
 161         [ drop major ]
 162     } cond ;
 163
 164 : last-semver-slot ( semver -- class )
 165     {
 166         { [ dup build>> length 0 > ] [ drop build ] }
 167         { [ dup prerelease>> length 0 > ] [ drop prerelease ] }
 168         { [ dup patch>> 0 > ] [ drop patch ] }
 169         { [ dup minor>> 0 > ] [ drop minor ] }
 170         { [ dup major>> 0 > ] [ drop major ] }
 171         [ drop major ]
 172     } cond ;
 173
 174 EBNF: parse-semver-range [=[
 175     logical-or = [\s\t]*~  '||'  [\s\t]*~
 176     range      = hyphen | simple ( [\s\t]*~ simple )*  => [[ first2 swap prefix ]]
 177     hyphen     = partial:p1 [\s\t]*~ '-':t  [\s\t]*~  partial:p2 => [[ p1 t  p2 3array ]]
 178     simple     = primitive | partial | tilde | caret
 179     primitive  = ( '~>' | '>=' | '<=' | '>' | '<' | '=' ) [\s\t]*~ partial
 180     partial    = xr ( '.' xr ( '.' xr qualifier? )? )? => [[ flatten concat ]]
 181     xr         = 'x' | 'X' | "*" | nr
 182     nr         = [0-9]+ => [[ string>number number>string ]]
 183     tilde      = '~'  [\s\t]*~  partial
 184     caret      = '^'  [\s\t]*~  partial
 185     qualifier  = ( '-' pre )? ( '+' build )?
 186     pre        = parts
 187     build      = parts
 188     parts      = part ( '.' part )*
 189     part       = nr | [-0-9A-Za-z]+ => [[ >string ]]
 190     range-set  = range? ( logical-or range? )* => [[ first2 swap prefix ]]
 191 ]=]