guile-semver/semver/parser.scm

(define-module (semver parser)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 rdelim)
  #:use-module (semver structs)
  #:use-module (semver matcher)
  #:export (parse
            parse-string
            ast->semantic-version))

(define %debug-level 0)       ; 1 verbose

(define (match-identifier tree)
  "Match TREE for a alphanumeric identifier. Return #f when no such
tree is recognised."
  (match tree
    (('alphanumeric-identifier v)
     v)
    (('numeric-identifier v)
     (string->number v))
    (_
     #f)))

;; TODO: This is ridiculously silly.
(define (flatten1 lst)
  "Flatten nested cdr list LST, with
structure (((elem1)((elem2)((elem3))))), and return it as a list with
structure ((elem1) (elem2) (elem3))."
  (let loop ((acc '())
	     (rest lst))
    (cond
     ((null? rest)
      (reverse acc))
     ((not (list? (car rest)))
      (loop (cons rest acc)
	    '()))
     (else
      (loop (cons (car rest) acc)
	    (cadr rest))))))

(define (flatten-separated-list tree)
  (match (reverse tree)
    ;; (()
    ;;  '())
    ((elem)
     `(,elem))
    (((rest ...) elem)
     `(,elem ,@(flatten1 rest)))))

(define (parse- input)
  ;; Semantic Version specification
  (define-peg-string-patterns
    "valid-semver <- version-core (hyphen-hide pre-release)? (plus-hide build)? 
   version-core <- major period-hide minor period-hide patch
   major <-- numeric-identifier
   minor <-- numeric-identifier
   patch <-- numeric-identifier
   pre-release <-- dot-separated-pre-release-identifiers
   dot-separated-pre-release-identifiers <- pre-release-identifier (period-hide pre-release-identifier)* 
   build <-- dot-separated-build-identifiers
   dot-separated-build-identifiers <- build-identifier (period-hide build-identifier)*
   pre-release-identifier <- numeric-identifier / alphanumeric-identifier 
   build-identifier <- alphanumeric-identifier 
   alphanumeric-identifier <-- identifier-character+
   numeric-identifier <-- (positive-digit digits) / [0] / positive-digit  
   identifier-character <- digit / non-digits
   non-digits <- letters / '-'
   digits <- digit+
   digit <- [0] / positive-digit
   positive-digit <- [1-9]
   letters <- [A-Za-z]+
   hyphen-hide < '-'
   plus-hide < '+'
   period-hide < '.'")
  (let* ((match (match-pattern valid-semver input))
  	 (end   (peg:end match))
  	 (pt    (peg:tree match)))
    (if (eq? (string-length input) end)
  	pt
  	(if match
  	    (begin
  	      (format (current-error-port) "parse error: at offset: ~a\n" end)
  	      (pretty-print pt (current-error-port))
  	      #f)
  	    (begin
  	      (format (current-error-port) "parse error: no match\n")
  	      #f)))))

(define (parse-string input)
  (let* ((pt (parse- input))
         (_ (when (> %debug-level 0) (display "tree:\n") (pretty-print pt))))
    pt))

(define (parse port)
  (parse-string (read-string port)))

(define (ast->semantic-version ast)
  "Return a <semantic-version> record from an AST representing a semantic
version."
  (define* (factory major-identifier minor-identifier patch-identifier
		    #:optional
		    (pre-release-identifier '())
		    (build-identifier '()))
    (make-semantic-version
     (match-identifier major-identifier)
     (match-identifier minor-identifier)
     (match-identifier patch-identifier)
     (if (not (null? pre-release-identifier))
	 (map match-identifier
	      (flatten-separated-list pre-release-identifier))
	 pre-release-identifier)
     (if (not (null? build-identifier))
	 (map match-identifier
	      (flatten-separated-list build-identifier))
	 build-identifier)))
  (match ast
    (((('major major) ('minor minor) ('patch patch))
      ('pre-release . pre-release) ('build . build))
     (factory major minor patch pre-release build))
    (((('major major) ('minor minor) ('patch patch))
      ('pre-release . pre-release))
     (factory major minor patch pre-release))
    (((('major major) ('minor minor) ('patch patch))
      ('build . build))
     (factory major minor patch '() build))
    ((('major major) ('minor minor) ('patch patch))
     (factory major minor patch))
    (_
     #f)))