(module testvectors-test-support

(;export
  test-info-data
  test-info-file
  test-info-text
  test-info-description
  load-testvectors)

(import scheme
  (chicken base) ;alist-update!, alist-ref
  (chicken type)
  (only (chicken blob) make-blob)
  (only (chicken pathname) make-pathname pathname-extension)
  (only (chicken io) read-line)
  (only (chicken file) directory)
  (only (chicken string) string-intersperse)
  (only (srfi 4) u8vector->blob u8vector-length read-u8vector)
  (only (srfi 1) first filter reverse!)
  (only srfi-13 string-null? string-downcase string-suffix? string-trim
        string-trim-right))

(define-type dirname string)
(define-type filename string)
(define-type pathname string)

(define-type alist (list-of (pair symbol *)))

(: test-info-data (alist --> blob))
(: test-info-file (alist --> filename))
(: test-info-text (alist --> (list-of string)))

(: test-info-description (alist --> string))

(: load-testvectors (dirname -> (list-of alist)))

;

(: info-files (dirname -> (list-of filename)))
(: info-filename? (pathname --> boolean))

(: info-pathname (dirname alist --> pathname))

(: read-testvector (dirname filename -> (or alist false)))

(: process-info ((or alist false) -> (or alist false)))
(: process-sha (symbol alist -> alist))
(: process-file (alist -> alist))

(: skip-whitelines (input-port -> boolean))

(: read-info-file (pathname -> (or alist false)))
(: read-info (input-port -> (or alist false)))
(: read-body (input-port -> (or string false)))
(: read-label (input-port -> (or string false)))
(: read-vector-data (pathname -> blob))

(: leading-whitespace? (string --> boolean))

(: *peek-line (input-port -> (or eof string)))
(: *read-line (input-port -> (or eof string)))

;;;

(define-constant MAX-DATA-LEN 1000000)

;;

;good enough
(define *peek-line)
(define *read-line)
(let ((+buf+ (the (or false eof string) #f)))
  (set! *peek-line
    (lambda (inp)
      (or +buf+
          (begin
            (set! +buf+ (read-line inp))
            +buf+))))
  (set! *read-line
    (lambda (inp)
      (if +buf+
          (let ((lin +buf+))
            (set! +buf+ #f)
            lin)
          (read-line inp)))) )

;NOTE *peek-line => eof is ONLY consumed by skip-whitelines - read-* procs do not
;"advance" the port-state

(define (skip-whitelines inp)
  (let loop ()
    (let ((lin (*peek-line inp)))
      (cond ((eof-object? lin)
              (*read-line inp) ;consume eof
              #f )
            ((string-null? (string-trim lin))
              (*read-line inp) ;consume empty line
              (loop) )
            (else
              #t ) ) ) ) )

(define (leading-whitespace? lin)
  (let ((tlin (string-trim lin)))
    (or (string-null? tlin)
        (< (string-length tlin) (string-length lin))) ) )

(define *empty-blob* (make-blob 0))

(define (read-vector-data pn)
  (let ((dat (call-with-input-file pn (cut read-u8vector MAX-DATA-LEN <>) #:binary)))
    (if (eof-object? dat) *empty-blob* (u8vector->blob dat)) ) )

(define (read-label inp)
  (let ((lbl (*read-line inp)))
    (and (not (eof-object? lbl))
         (begin
           (when (leading-whitespace? lbl)
             (error 'read-label "label with leading whitespace" lbl))
           (unless (string-suffix? ":" lbl)
             (error 'read-label "label missing colon" lbl))
           (string-trim-right lbl #\:) ) ) ) )

(define (read-body inp)
  (define (finish-result ls)
    ;drop any trailing empty-line (convention in .info)
    (reverse! (if (string-null? (car ls)) (cdr ls) ls)) )
  (let loop ((ls '()))
    (let ((lin (*peek-line inp)))
      (if (eof-object? lin)
          (finish-result ls)
          (let* ((olin (string-trim-right lin))
                 (lin (string-trim olin)) )
            ;no leading whitespace is termination
            (if (and (not (string-null? lin))
                     (= (string-length lin) (string-length olin)))
                (finish-result ls)
                (begin
                  (*read-line inp) ;consume line
                  (loop (cons lin ls)) ) ) ) ) ) ) )

(define (read-info inp)
  (define (finish-result als)
    (and (not (null? als)) als) )
  (define (canon-label lbl)
    (string->symbol (string-downcase lbl)) )
  (let loop ((als '()))
    (if (not (skip-whitelines inp))
        (finish-result als)
        (let ((lbl (read-label inp)))
          (if (not lbl)
              (finish-result als)
              (let* ((cel (cons (canon-label lbl) (read-body inp)))
                     (nals (cons cel als)) )
                (if (not (cdr cel))
                    nals
                    (loop nals) ) ) ) ) ) ) )

(define (read-info-file pn) (call-with-input-file pn read-info #:text))

(define (info-pathname dir als) (make-pathname dir (alist-ref 'file als)))

(define (info-filename? fn) (string=? "info" (pathname-extension fn)))

(define (info-files dir) (filter info-filename? (directory dir)))

(define (process-file als)
  (alist-update! 'file (first (alist-ref 'file als)) als) )

(define (process-sha key als)
  (alist-update! key (apply string-append (alist-ref key als)) als) )

(define (process-info als)
  (and als
       (process-file
         (process-sha 'sha512
           (process-sha 'sha384
             (process-sha 'sha256 als))))) )

(define (read-testvector dir fn)
  (and-let* ((als (process-info (read-info-file (make-pathname dir fn)))))
    (alist-update! 'data (read-vector-data (info-pathname dir als)) als) ) )

;;;

(define (test-info-data als) (alist-ref 'data als))
(define (test-info-file als) (alist-ref 'file als))
(define (test-info-text als) (alist-ref 'description als))

(define (test-info-description als)
  (string-intersperse (test-info-text als) "\n") )

(define (load-testvectors dir)
  (map (cut read-testvector dir <>) (info-files dir)) )

) ;module testvectors-test-support