;; 
;; %%HEADER%%
;; 

(module missbehave-matchers
( expect-at-least-n-applications
  expect-at-most-n-applications
  expect-exactly-n-applications
  ignore-arguments 
  match-arguments
  make-call-matcher
  message-from-predicate-form
  be close-to any-of none-of
  list-including
  have-type
  match-string
  call
  raise
  make-error-matcher
  )

(import chicken scheme extras data-structures irregex ports)
(require-extension missbehave advice (only srfi-1 every))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Procedure-Expections
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (format-times n)
  (if (= n 1) "once" (sprintf "~A times" n))) 

(define ((expect-at-least-n-applications proc n) applications)
  (values
   (>= applications n)
   (sprintf "Expected ~A to be called at least ~A, but was called ~A" proc (format-times n) (format-times applications))))

(define ((expect-at-most-n-applications proc n) applications)
  (values
   (<= applications n)
   (sprintf "Expected ~A to be called at most ~A, but was called ~A" proc (format-times n) (format-times applications))))

(define ((expect-exactly-n-applications proc n) applications)
  (values
   (= applications n)
   (sprintf "Expected ~A to be called ~A, but was called ~A" proc (format-times n) (format-times applications))))

(define ((ignore-arguments) . _)
  (values  #t ""))

(define ((match-arguments proc . args) arguments)
  (values
   (equal? arguments args)
   (sprintf "Expected ~A to be called with ~A, but was called with ~A" proc args arguments)))


(define-syntax call
  (syntax-rules (once twice times time never with)
    ((_ proc (with arg arg+ ...))
     (make-call-matcher proc
                        (expect-at-least-n-applications (quote proc) 1)
                        (match-arguments (quote proc) arg arg+ ...)))

    ((_ proc (with arg arg+ ...) once)
     (make-call-matcher proc
                        (expect-exactly-n-applications (quote proc) 1)
                        (match-arguments (quote proc) arg arg+ ...)))
    ((_ proc (with arg arg+ ...) twice)
     (make-call-matcher proc
                        (expect-exactly-n-applications (quote proc) 2)
                        (match-arguments (quote proc) arg arg+ ...)))

    ((_ proc (with arg arg+ ...) never)
     (make-call-matcher proc
                        (expect-exactly-n-applications (quote proc) 0)
                        (match-arguments (quote proc) arg arg+ ...)))

    ((_ proc (with arg arg+ ...) (n time))
     (make-call-matcher proc
                        (expect-exactly-n-applications (quote proc) n)
                        (match-arguments (quote proc) arg arg+ ...)))

    ((_ proc (with arg arg+ ...) (n times))
     (make-call-matcher proc
                        (expect-exactly-n-applications (quote proc) n)
                        (match-arguments (quote proc) arg arg+ ...)))
    ((_ proc never)
     (call proc (0 times)))
    ((_ proc once)
     (call proc (1 time)))
    ((_ proc twice)
     (call proc (2 times)))
    ((_ proc (n times))
     (make-call-matcher proc
                        (expect-exactly-n-applications (quote proc) n)
                        (ignore-arguments)))
    ((_ proc (n time))
     (make-call-matcher proc
                        (expect-exactly-n-applications (quote proc) n)
                        (ignore-arguments)))))




(define (make-call-matcher  procedure application-count-matcher argument-matcher)
  (let* ((applications 0)
         (arguments (unspecified))
         (counting-advice (lambda (proc  args)
                            (set! applications (+ 1 applications))
                            (apply proc args)))
         (arguments-advice (lambda (proc  args)
                             (set! arguments args)
                             (apply proc args))))
    (make-matcher
     check: (lambda (subject)
              (dynamic-wind
                  (lambda ()
                    (advise 'around procedure counting-advice)
                    (advise 'around procedure arguments-advice))
                  (lambda ()
                    (force subject)
                    (and (application-count-matcher applications) (argument-matcher arguments)))
                  (lambda () (unadvise procedure))))
     
     failure-message-generator: (lambda (form subject negate)
                                  (receive (count-matched count-message) (application-count-matcher applications)
                                      (receive (arguments-matched argument-message) (argument-matcher arguments)
                                          (cond
                                           ((not count-matched)
                                            (if (not arguments-matched)
                                                 (sprintf "~A.  Additionally: ~A" count-message argument-message)
                                                 (sprintf "~A" count-message)))
                                           (else (sprintf "~A" argument-message)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regex
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




(define (match-string what #!key (with-matches #f))
  (let ((missmatch #f))
    (matcher
     (check (subject)
       (if with-matches
           (let ((matches (irregex-match (force subject) what)))
             (call-with-current-continuation
              (lambda (return)
                (for-each
                 (lambda (submatch)
                   (unless matches
                     (return #f))
                   (unless (and  (irregex-match-valid-index? matches (car submatch))
                                 (equal? (irregex-match-substring matches (car submatch)) (cdr submatch)))
                     (set! missmatch submatch)
                     
                     (return #f)))
                 with-matches)
                #t)))
           (irregex-match (force subject) what)))
     (message (form subject negate)
       (if with-matches
           (if missmatch
               (if negate
                   (sprintf "Expected ~A not to include submatch ~A when matched against ~S" form missmatch what)
                   (sprintf "Expected ~A to include submatch ~A when matched against ~S" form missmatch what))
               (if negate
                   (sprintf "Exepcted ~A not to match ~S" form what)
                   (sprintf "Expected ~A to match ~S" form what)))
           (if negate
               (sprintf "Expected ~A not to match ~S" form what)
               (sprintf "Expected ~A to match ~S" form what)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Be
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (message-from-predicate-form form)
  (if (list? form)
      (let ((name (symbol->string (car form))))
        (with-output-to-string
          (lambda ()
            (display (string-translate name "-" " "))
            (display " ")
            (for-each (cut printf "~A " <>) (cdr form)))))
      form))

(define-syntax be
  (syntax-rules (a an true false)
    ((_ true)
     (be #t))
    ((_ false)
     (be #f))
    ((_ a type)
     (have-type type))
    ((_ an type)
     (have-type type))
    ((_ pred-or-value)
     (matcher
      (check (subject)
        (if (procedure? pred-or-value)
            (pred-or-value (force subject))
            (equal? pred-or-value (force subject))))
      (message (form subject negate)
        (if negate
            (if (procedure? pred-or-value)
                (sprintf "Expected ~S not to be ~A" (force subject) (message-from-predicate-form (quote pred-or-value)))
                (sprintf "Expected ~S not to be ~S" (force subject) pred-or-value))
            (if (procedure? pred-or-value)
                (sprintf "Expected ~S to be ~A" (force subject) (message-from-predicate-form (quote pred-or-value)))
                (sprintf "Expected ~S to be ~S" (force subject) pred-or-value))))))
    ((_ pred value more-values ...)
     (matcher
      (check (subject)
         (apply pred (list (force subject) value more-values ...)))
      (message (form subject negate)
        (with-output-to-string
          (lambda ()
            (if negate
                (printf "Expected ~S not to be ~S" (force subject) (quote pred))
                (printf "Expected ~S to be ~S" (force subject) (quote pred)))
            (for-each
             (lambda (val)
               (printf " ~S" val))
             (list value more-values ...)))))))))




(define-syntax have-type
  (lambda (form rename env)
    (let* ((type (cadr form))
           (type-pred (string->symbol (conc (symbol->string type) "?")))
           (%make-matcher (rename 'make-matcher)))
      `(,%make-matcher check: (lambda (subject)
                                (,type-pred (force subject)))
                       failure-message-generator: (lambda (form subject negate)
                                                    (if negate
                                                        (sprintf "Expected ~S to not be a ~A" (force subject) (quote ,type))
                                                        (sprintf "Expected ~S to be a ~A" (force subject) (quote ,type))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Be helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define ((close-to what #!key (delta 0.3)) actual)
  (<= (abs (- what actual)) delta))

(define ((any-of item . more-items) subject)
  (member subject (cons item more-items)))

(define ((none-of item . more-items) subject)
  (not (member subject (cons item more-items))))

(define ((list-including item . more-items) subject)
  (and (list? subject)
       (every (cut member <> subject) (cons item more-items))))

(define ((vector-including item . more-items) subject) #t)
(define ((hash-table-including item . more-items) subject) #t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Have/Has
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; raise
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax raise
  (syntax-rules (error errors with)
    ((_ error)
     (make-error-matcher))
    ((_ errors)
     (make-error-matcher))
    ((_ (kind more-kinds ...))
     (make-error-matcher kinds: '(kind more-kinds ...)))))

(define (make-error-matcher #!key (kinds #f) (properties #f))
  (let ((message "")
        (negative-message ""))
    (make-matcher
     check: (lambda (code)
              (handle-exceptions exn
                  (let* ((condition (condition->list exn))
                         (exn-kinds (map car condition)))
                    (cond
                     ((and kinds properties) #t)
                     (kinds
                      (if (every (cut member <> exn-kinds) kinds)
                          #t
                          (begin
                            (set! message (sprintf "Expected exn of kinds ~A but got ~A" kinds exn-kinds))
                                        ;FIXME find proper wording
                            (set! negative-message (sprintf "Expected exn not of kinds ~A but got ~A" kinds exn-kinds))
                            #f)))
                     (properties #t)
                     (else
                      (set! message            (sprintf "Expecte errors but didn't get one"))
                      (set! negative-message   (sprintf "Expected no errors but got one"))
                      #t)))
                (force code)
                #f))
     failure-message-generator: (lambda (form subject negate)
                                  (if negate
                                      negative-message
                                      message)))))

)