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