extra/semver/semver.factor

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