#! /usr/bin/scheme-script

(import (rnrs)
        (fmt fmt)
        (list-utils)
        (functional-tests)
        (cache-functional-tests)
        (era-functional-tests)
        (parser-combinators)
        (only (srfi s1 lists) break)
        (regex)
        (srfi s8 receive)
	(temp-file)
        (thin-functional-tests))

;;------------------------------------------------

;; Returns #t if the xs list matches prefix
(define (begins-with prefix xs)
  (cond
    ((null? prefix) #t)
    ((null? xs) #f)
    ((eq? (car prefix) (car xs))
     (begins-with (cdr prefix) (cdr xs)))
    (else #f)))

(define (split-list xs sep)
  (define (safe-cdr xs)
    (if (null? xs) '() (cdr xs)))

  (if (null? xs)
      '()
      (receive (p r) (break (lambda (c)
                          (eq? c sep))
                        xs)
           (cons p (split-list (safe-cdr r) sep)))))

(define (string->syms str sep)
  (map (lambda (cs)
         (string->symbol
           (list->string cs)))
       (split-list (string->list str) sep)))

(define (mk-string-matcher pattern)
  (let ((prefix (string->syms pattern #\/)))
   (lambda (keys)
    (begins-with prefix keys))))

(define (mk-regex-matcher pattern)
  (let ((rx (regex pattern)))
    (lambda (keys)
      (rx (apply string-append
                 (intersperse "/"
                              (map symbol->string keys)))))))

;; If the filter begins with 're:' then we make a regex matcher, otherwise
;; we use a simple string matcher.
(define (mk-single-matcher pattern)
  (if (string=? (substring pattern 0 3) "re:")
      (mk-regex-matcher (substring pattern 3 (string-length pattern)))
      (mk-string-matcher pattern)))

(define (mk-filter patterns)
  (if (null? patterns)
      ; accept everything if no patterns
      (lambda (_) #t)

      ; Otherwise accept tests that pass a pattern
      (let ((filters (map mk-single-matcher patterns)))
       (fold-left (lambda (fn-a fn-b)
                    (lambda (keys)
                      (or (fn-a keys)
                          (fn-b keys))))
                  (car filters)
                  (cdr filters)))))

(define (exec-help)
  (fmt (current-error-port)
       (dsp "here's some helpful help\n")))

(define (exec-run args)
  (let ((pred (mk-filter args)))
   (if (run-scenarios (filter pred (list-scenarios)))
       (exit)
       (exit #f))))

(define (exec-list args)
  (let ((pred (mk-filter args)))
   (describe-scenarios (filter pred (list-scenarios)))))

;;------------------------------------------------
;; Command line parser

(define whitespace
  (many+ (charset " \t\n")))

(define (whitespace-delim ma)
  (>> (opt whitespace)
      (<* ma (opt whitespace))))

(define (cmd-word str)
  (whitespace-delim (lit str)))

(define (switch str)
  (whitespace-delim (>> (lit "--") (lit str))))

(define not-switch
  (whitespace-delim
   (parse-m (<- c (neg-charset "- \t"))
    (<- cs (many* (neg-charset " \t")))
    (pure (list->string (cons c cs))))))

(define (maybe ma)
 (alt (>> ma (pure #t))
  (pure #f)))

(define help-command-line
 (>> (cmd-word "help") (pure exec-help)))

(define run-command-line
 (parse-m
  (cmd-word "run")
  (<- dunlink (maybe (switch "disable-unlink")))
  (<- args (many* not-switch))
  (pure (lambda ()
	 (if dunlink
	  (disable-unlink (exec-run args))
	  (exec-run args))))))

(define list-command-line
  (parse-m
    (cmd-word "list")
    (<- args (many* not-switch))
    (pure (lambda () (exec-list args)))))

(define command-line-parser
 (one-of help-command-line
         run-command-line
         list-command-line))

(define (bad-command-line)
  (fmt (current-error-port) (dsp "bad command line\n")))

;; (<string>) -> thunk
(define (parse-command-line)
  (let ((args (cdr (command-line))))
    (receive (v st)
             (parse command-line-parser
                    (apply string-append
                           (intersperse " " (cdr (command-line)))))
             (if (success? st)
                 v
                 bad-command-line))))

;;------------------------------------------------

(register-thin-tests)
(register-cache-tests)
(register-era-tests)

(with-dir "test-output"
 ((parse-command-line)))