;;;; semantic-version-internals.scm  -*- Scheme -*-

;FIXME semantic-version API is (unsafe unchecked inline) so cannot use #!optional

(define-inline (->boolean x) (and x #t))

;;record-variants

(define-syntax define-record-type-variant
  (er-macro-transformer
   (lambda (form r c)
     (define (any p L)
       (and (pair? L)
            (or (p (car L))
                (any p (cdr L)))))
     (##sys#check-syntax 'define-record-type-variant form
                         '(_ _ #(variable 0)
                             #(variable 1) _ . _))
     (let* ((name-spec (cadr form))
            (name (if (pair? name-spec) (car name-spec) name-spec))
            (t (if (pair? name-spec) (cadr name-spec) name-spec))
            (variant? (lambda (type) (any (lambda (x) (c x (r type)))
                                          (caddr form))))
            (unsafe? (variant? 'unsafe))
            (unchecked? (variant? 'unchecked))
            (inline? (variant? 'inline))
            (constructor? (eq? name t))

            (conser (cadddr form))
            (predspec (car (cddddr form)))
            (pred (if (pair? predspec) (car predspec) predspec))
            (checker (if (and (pair? predspec)
                              (pair? (cdr predspec)))
                         (cadr predspec) #f))
            (slots (cdr (cddddr form)))
            (%begin (r 'begin))
            (%lambda (r 'lambda))
            (%define (if inline? (r 'define-inline) (r 'define)))
            (vars (cdr conser))
            (x (r 'x))
            (y (r 'y))
            (%getter-with-setter (r 'getter-with-setter))
            (slotnames (map car slots)))
       `(,%begin
         ,(if constructor?
              `(,%define ,conser
                         (##sys#make-structure
                          ,t
                          ,@(map (lambda (sname)
                                   (if (memq sname vars)
                                       sname
                                       '(##core#undefined)))
                                 slotnames)))
              `(,%begin))
         (,%define (,pred ,x) (##sys#structure? ,x ,t))
         ,(if checker
              `(,%define (,checker ,x)
                         (##core#check (##sys#check-structure ,x ,t)))
              `(,%begin))
         ,@(let loop ([slots slots] [i 1])
             (if (null? slots)
                 '()
                 (let* ([slot (car slots)]
                        (setters (memq #:record-setters ##sys#features))
                        (setr? (pair? (cddr slot)))
                        (getr `(,%lambda (,x)
                                         ,(if unchecked?
                                              `(,%begin)
                                              `(##core#check
                                                (##sys#check-structure ,x ,t)))
                                         ,(if unsafe?
                                              `(##sys#slot ,x ,i)
                                              `(##sys#block-ref ,x ,i)))))
                   `(,@(if setr?
                           `((,%define (,(caddr slot) ,x ,y)
                                       ,(if unchecked?
                                            `(,%begin)
                                            `(##core#check
                                              (##sys#check-structure ,x ,t)))
                                       ,(if unsafe?
                                            `(##sys#setslot ,x ,i ,y)
                                            `(##sys#block-set! ,x ,i ,y))))
                           '())
                     (,%define ,(cadr slot)
                               ,(if (and setr? setters)
                                    `(,%getter-with-setter ,getr ,(caddr slot))
                                    getr) )
                     ,@(loop (cdr slots) (add1 i)))))))))))

;; semantic-version type

(define semantic-version 'semantic-version)
(define-record-type-variant semantic-version (unsafe unchecked inline)
  (make-ver cs ps)
  ver?
  (cs ver-parts ver-parts-set!)
  (ps ver-puncs ver-puncs-set!))

(define-inline (vertyp? x) (and (ver? x) (list? (ver-parts x)) (list? (ver-puncs x))))

(define-inline (copy-ver-parts ver) (list-copy (ver-parts ver)))
(define-inline (copy-ver-puncs ver) (list-copy (ver-puncs ver)))

(define-inline (copy-ver v) (make-ver (copy-ver-parts ver) (copy-ver-puncs ver)))

;NOTE symbols are not preserved; the printname is used!
(define-inline (ver-part? x) (or (number? x) (string? x) (symbol? x)))
(define-inline (ver-punc? x) (char? x))

(define-inline (ver-parts? l) (every ver-part? l))
(define-inline (ver-puncs? l) (every ver-punc? l))

(define-inline (ver-depth ver) (length (ver-parts ver)))

;;

(define-inline (badargmsg msg #!optional nam)
  (string-append (or (and nam (->string nam)) "bad argument") " - " msg) )

(define-inline (badargerr loc obj msg #!optional nam)
  (error loc (badargmsg msg nam) obj) )

;FIXME use badargerr so can have descriptive argument name

(define-inline (check-fixnum loc obj #!optional nam) (##sys#check-fixnum obj loc) obj)
(define-inline (check-number loc obj #!optional nam) (##sys#check-number obj loc) obj)
(define-inline (check-string loc obj #!optional nam) (##sys#check-string obj loc) obj)
(define-inline (check-procedure loc obj #!optional nam) (##sys#check-procedure obj loc) obj)

(define-inline (check-range loc i from to #!optional nam) (##sys#check-range i from to loc) i)

(define-inline (check-parts loc x #!optional nam)
  (unless (ver-parts? x) (badargerr loc x "invalid semantic-version parts" nam))
  x )

(define-inline (check-puncs loc x #!optional nam)
  (unless (ver-puncs? x) (badargerr loc x "invalid semantic-version puncs" nam))
  x )

;;

(define-inline (default-punctuation) (string-ref (version-punctuation) 0))

(define-inline (default-puncs parts) (make-list (sub1 (length parts)) (default-punctuation)))