guile-semver/semver/parser-range.scm

(define-module (semver parser-range)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg)
  #:use-module (semver structs)
  #:use-module (semver matcher)
  #:export (parse-semver-range))

(define-peg-string-patterns
  "range-set <- range (logical-or range) * 
   logical-or <-- (whitespace)* '||' (whitespace)*
   qualifier <-- ('-' pre)? ('+' range)?  
   pre <- parts
   range <- parts
   parts <- part ('.' part)*  
   part <- nr / [-0-9A-Za-z]+
   nr <- [1-9] ([0-9])* / [0] 
   xr <- 'x' / 'X' / '*' / nr
   lt <-- '<'
   lte <-- '<' '='
   gt <-- '>'
   gte <-- '>' '='
   eq <-- '='
   partial <-- xr ('.' xr ('.' xr qualifier ? )? )?
   hyphen <-- partial (whitespace)+ '-' (whitespace)+ partial
   primitive <- ( gte /gt / lte /lt / eq) (whitespace)* partial 
   tilde <-- '~' (whitespace)* partial
   caret <-- '^' (whitespace)* partial
   simple <- primitive / partial / tilde / caret
   range <- hyphen / (simple (whitespace+ simple)*)
   whitespace < ' ' / '\t'")

(define (parse-semver-range expr)
  "Parse EXPR for a valid (prefix) semantic version range
string. Return #f when no such string is recognised."
  (define (split str)
    (string-split str #\.))
  (define (semver-range-from-str str)
    (apply semver-range-partial (split str)))
  (define (matcher tree)
    (match tree
      ((left (('logical-or _) right))
       (semver-range-or (matcher left)
			(matcher right)))
      (('partial v)
       (semver-range-from-str v))
      ((('eq _) ('partial v))
       (semver-range-from-str v))
      ((('lt _) ('partial v))
       (semver-range-lt (semver-range-from-str v)))
      ((('gt _) ('partial v))
       (semver-range-gt (semver-range-from-str v)))
      ((('lte _) ('partial v))
       (semver-range-lte (semver-range-from-str v)))
      ((('gte _) ('partial v))
       (semver-range-gte (semver-range-from-str v)))
      (('tilde _ ('partial v))
       (semver-range-tilde (semver-range-from-str v)))
      (('caret _ ('partial v))
       (semver-range-caret (semver-range-from-str v)))
      (('hyphen ('partial v-left) _ ('partial v-right))
       (semver-range-hyphen (semver-range-from-str v-left)
			    (semver-range-from-str v-right)))
      ((left ((('logical-or _) all-right) ...))
       (fold semver-range-or (matcher left)
	     (map matcher all-right)))
      ((left right)
       (semver-range-and (matcher left)
			 (matcher right)))
      (_
       (error "We could not parse that quite right."))))
  (let ((parsed (peg:tree (match-pattern range-set expr))))
    (matcher parsed)))