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