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 io
   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 : <semver> ( str -- semver ) parse-semver ; inline
  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. ( semver -- )
  69     semver>string print ;
  70
  71 : semver-inc-major ( semver -- semver )
  72     dup prerelease>> [
  73         [ 1 + ] change-major
  74         0 >>minor
  75         0 >>patch
  76         "" >>prerelease
  77         "" >>build
  78     ] [
  79         drop
  80         "" >>prerelease
  81         "" >>build
  82     ] if-empty ;
  83
  84 : semver-inc-minor ( semver -- semver )
  85     dup prerelease>> [
  86         [ 1 + ] change-minor
  87         0 >>patch
  88         "" >>prerelease
  89         "" >>build
  90     ] [
  91         drop
  92         "" >>prerelease
  93         "" >>build
  94     ] if-empty ;
  95
  96 : semver-inc-patch ( semver -- semver )
  97     dup prerelease>> [
  98         [ 1 + ] change-patch
  99         "" >>prerelease
 100         "" >>build
 101     ] [
 102         drop
 103         "" >>prerelease
 104         "" >>build
 105     ] if-empty ;
 106
 107 : semver-inc-prerelease ( semver -- semver )
 108     dup prerelease>> [
 109         "0"
 110     ] [
 111         "." split
 112         dup [ string>number ] find-last [
 113             over [ ?inc-string ] change-nth
 114             "." join
 115         ] [
 116             2drop "dev.0"
 117         ] if
 118     ] if-empty >>prerelease
 119     "" >>build ;
 120
 121 : semver-inc-prerelease-id ( semver id -- semver )
 122     over prerelease>> [
 123         "0" "." glue
 124     ] [
 125         2dup swap head? [
 126             "." split
 127             dup [ string>number ] find-last [
 128                 over [ ?inc-string ] change-nth
 129                 "." join nip
 130             ] [
 131                 2drop "0" "." glue
 132             ] if
 133         ] [
 134             drop "0" "." glue
 135         ] if
 136     ] if-empty >>prerelease
 137     "" >>build ;
 138
 139 : semver-inc-prepatch ( semver -- semver )
 140     [ 1 + ] change-patch
 141     "dev.0" >>prerelease
 142     "" >>build ;
 143
 144 : semver-inc-preminor ( semver -- semver )
 145     [ 1 + ] change-minor
 146     0 >>patch
 147     "dev.0" >>prerelease
 148     "" >>build ;
 149
 150 : semver-inc-premajor ( semver -- semver )
 151     [ 1 + ] change-major
 152     0 >>minor
 153     0 >>patch
 154     "dev.0" >>prerelease
 155     "" >>build ;
 156
 157 GENERIC: lower-range ( obj -- str )
 158
 159 M: string lower-range ( obj -- semver )
 160     parse-semver semver>string ">=" prepend ;
 161
 162 M: array lower-range ( obj -- semver )
 163     parse-semver semver>string ">=" prepend ;
 164
 165 GENERIC: upper-range ( obj -- str )
 166
 167 M: string upper-range ( obj -- semver )
 168     parse-semver semver>string "<=" prepend ;
 169
 170 M: array upper-range ( obj -- semver )
 171     parse-semver semver>string "<=" prepend ;
 172
 173 : major-minor-patch-compare ( s1 s2 -- <=> part )
 174     2dup [ major>> ] compare
 175     dup +eq+ eq? [
 176         drop 2dup [ minor>> ] compare
 177         dup +eq+ eq? [
 178             drop [ patch>> ] compare patch
 179         ] [
 180             2nip minor
 181         ] if
 182     ] [
 183         2nip major
 184     ] if ; inline
 185
 186 : compare-prelreases ( semver1 semver2 -- <=> )
 187     [ prerelease>> ] bi@ over empty? [
 188         nip empty? +eq+ +gt+ ?
 189     ] [
 190         dup empty? [ 2drop +lt+ ] [
 191             [ split-numbers ] bi@
 192             f pad-longest zip [
 193                 first2
 194                 {
 195                     { [ 2dup [ integer? ] both? ] [ <=> ] }
 196                     { [ 2dup [ string? ] both? ] [ <=> ] }
 197                     { [ over integer? ] [ 2drop +lt+ ] }
 198                     { [ dup integer? ] [ 2drop +gt+ ] }
 199                     { [ over f = ] [ 2drop +lt+ ] }
 200                     { [ dup f = ] [ 2drop +gt+ ] }
 201                     [ 2drop +eq+ ]
 202                 } cond
 203             ] [
 204                 +eq+ = not
 205             ] find-pred 2drop
 206         ] if
 207     ] if ;
 208
 209 M: semver <=>
 210     2dup major-minor-patch-compare drop
 211     dup +eq+ = [ drop compare-prelreases ] [ 2nip ] if ;
 212
 213 EBNF: parse-range [=[
 214     logical-or = [\s\t]*~  '||'  [\s\t]*~
 215     range      = hyphen | simple ( [\s\t]*~ simple )*  => [[ first2 swap prefix ]]
 216     hyphen     = partial:p1 [\s\t]*~ '-':t  [\s\t]*~  partial:p2 => [[ p1 t  p2 3array ]]
 217     simple     = primitive | partial | tilde | caret
 218     primitive  = ( '~>' | '>=' | '<=' | '>' | '<' | '=' ) [\s\t]*~ partial
 219     partial    = xr ( '.' xr ( '.' xr qualifier? )? )? => [[ flatten concat ]]
 220     xr         = 'x' | 'X' | "*" | nr
 221     nr         = [0-9]+ => [[ string>number number>string ]]
 222     tilde      = '~'  [\s\t]*~  partial
 223     caret      = '^'  [\s\t]*~  partial
 224     qualifier  = ( '-' pre )? ( '+' build )?
 225     pre        = parts
 226     build      = parts
 227     parts      = part ( '.' part )*
 228     part       = nr | [-0-9A-Za-z]+ => [[ >string ]]
 229     range-set  = range? ( logical-or range? )* => [[ first2 swap prefix ]]
 230 ]=]
 231