#lang scheme/base

(provide (all-defined-out))

(define-syntax try-parsing 
  (syntax-rules ()
    [(_ v () body) (body v)]
    [(_ v ([id expr] [id2 expr2] ...) body)
     (let-values ([(this rest) (expr v)])
       (let ([id this])
         (try-parsing rest ([id2 expr2] ...) body)))]))

;; get-next-fragment : regexp -> [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; helper for the below two functions
(define (((get-next-fragment rx) #:on-error [error-action (λ (s) (values #f s))]) str)
  (let ([thematch (regexp-match rx str)])
    (cond
      [(not thematch) (error-action str)]
      [else
       (let ([this (list-ref thematch 1)]
             [rest (list-ref thematch 2)])
         (values this rest))])))

;; get-next-slash : [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; splits the given string into the nonempty substring before the first slash and the substring after it
;; on failure returns whatever the given #:on-error function returns when given the entire string
(define get-next-slash (get-next-fragment #rx"^([^/]+)/(.*)$"))
(define get-next-slash-or-end (get-next-fragment #rx"^([^/]+)/?(.*)$"))

;; get-to-next-colon-or-end : [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; splits the given string into the nonempty substring before the initial : and the substring after it, or 
;; (values [initial-string] "") if the given string has no : in it.
(define get-to-next-colon-or-end (get-next-fragment #rx"^([^:]+):?(.*)$"))

;; parse-package : string stx -> (values string nat min-spec)
;; given a package specifier, returns the package name, the package major version, and a descriptor
;; for the acceptible minor versions
(define (parse-package package stx)
  (try-parsing package
               ([pkgname (get-to-next-colon-or-end)]
                [maj     (get-to-next-colon-or-end)])
               (λ (min) 
                 (values (parse-pkgname pkgname stx) 
                                (parse-majspec maj     stx)
                                (parse-minspec min     stx)))))

;; parse-pkgname : string stx -> string
;; given a literal package name string as it would appear in shorthand syntax, returns
;; a fully-embellished name for the package being specified. stx is provided as an object
;; to blame in syntax errors if something goes wrong
(define (parse-pkgname pn stx)
  (let ([m (regexp-match #rx"\\.plt$" pn)])
    (if m pn (string-append pn ".plt"))))

;; parse-majspec : (#f stx -> #f) intersect (string stx -> number)
;; given the literal major version string (or #f) returns the major version corresponding
;; to that string. stx is the syntax object to blame if something goes wrong 
(define (parse-majspec majstr stx)
  (cond
    [(not majstr) #f]
    [else
     (cond
       [(and (regexp-match #rx"^[0-9]+$" majstr))
        (let ([n (string->number majstr)])
          (if (> n 0)
              n
              (raise-syntax-error #f
                                  (format "Illegal major version specifier; expected version number greater than 0, received ~e" majstr))))]
       [else (raise-syntax-error #f 
                                 (format "Illegal major version specifier; expected positive integer, received ~e" majstr)
                                 stx)])]))

;; regexp-case : SYNTAX
;; provides a case operation for trying different regular expressions in sequence on a test string,
;; stoppingas soon as one of those expressions matches the string. If one does, then all the
;; parenthesized subparts are bound to names in the right-hand side of the corresponding clause
(define-syntax regexp-case
  (syntax-rules ()
    [(_ str clause ...)
     (let ([s str])
       (regexp-case* s clause ...))]))

(define-syntax regexp-case*
  (syntax-rules (else)
    [(_ str [else body] c ...)
     body]
    [(_ str [re ([id ...] body)] c ...)
     (let ([args (regexp-match re str)])
       (if args
           (let-values ([(id ...) (apply values (cdr args))]) body)
           (regexp-case* str c ...)))]))

;; parse-minspec : string stx -> min-spec
;; returns the minor-version specification corresponding to the given string as an s-expression.
;; stx is the syntax object to blame if the string doesn't correspond to minor-version spec. 
(define (parse-minspec minstr stx)
  (cond
    [(not minstr) #f]
    [else
     (regexp-case minstr
       [#rx"^>=([0-9]+)$"        ((n)   `(+ ,(string->number n)))]
       [#rx"^<=([0-9]+)$"        ((n)   `(- ,(string->number n)))]
       [#rx"^=([0-9]+)$"         ((n)   `(= ,(string->number n)))]
       [#rx"^([0-9]+)-([0-9]+)$" ((m n) `(,(string->number m) ,(string->number n)))]
       [#rx"^([0-9]+)$"          ((n)   (string->number n))]
       [#rx"^$"                  (()    #f)] ;; here for convenience reasons. a bit gross, i know
       [else
        (raise-syntax-error #f
                            (format "Illegal minor version specifier; expected <=n, >=n, =n, n-m, or n, where n, m are positive integers; received ~e" minstr)
                            stx)])]))