;; 
;; %%HEADER%%
;;

(module missbehave
(
  run-specification behave call-with-specification make-empty-specification
                    
  describe context run-context call-with-context add-context-to-specification
  context-description create-context context? context-parent
  
  add-hook-to-context before after
  subject-set! subject 
 
  it create-example example-description run-example 
  add-example-to-context pending 

  example-result? example? example-result-example example-result-messages
  example-failed? example-pending? example-result-spec-file
  example-spec-file 
 
  expect run-expectation call to
  make-matcher
  
  be have-type 
  stub! returns with-stubs! clear-stubs! make-call-matcher

  expect-at-least-n-applications
  expect-at-most-n-applications
  expect-exactly-n-applications
  ignore-arguments 
  match-arguments
  *current-context* context-subject-set!
  $ reset-state!
  current-spec-file
  negative-expectation
  do-not
  raise make-error-matcher

  )

(import chicken scheme extras data-structures ports)
(require-library defstruct srfi-1 regex advice srfi-69)

(import srfi-1)
(import regex)
(import advice)
(import defstruct)
(import (only srfi-69 hash-table-set! hash-table-ref/default hash-table-clear! make-hash-table))

(define current-spec-file (make-parameter ""))

;; Utils
(define-syntax returning
  (syntax-rules ()
    ((_ object code more-code ...)
     (let ((return-later object))
       code more-code ...
       return-later))))

;; Specification
;; =============
;; A specification is simple the collection of all contexts and
;; descriptions

(define (make-empty-specification) (list))
(define *current-specification*    (make-parameter (make-empty-specification)))

(define (call-with-specification specification thunk)
  (parameterize ((*current-specification* specification))
    (thunk)
    (*current-specification*)))

(define (run-specification specification #!key (include #f) (exclude #f) (reporter (make-standard-reporter)))
  (let ((contexts (filter-contexts specification include exclude)))
    (for-each (cut run-context <> reporter include exclude) contexts)
    (reporter #f mode: 'summary)))

(define (behave thunk)
  (if (run-specification
       (call-with-specification
        (make-empty-specification)
        thunk))
      0 1))

(define (filter-contexts contexts include exclude)
  (cond
   ((and (not include) (not exclude)) contexts)
   ((not exclude)
    (filter
     (lambda (ctx)
       (or
        (meta-matches? (context-meta ctx) include)
        (context-has-matching-examples? ctx include: include))) contexts))
   ((not include)
    (filter
     (lambda (ctx)
       (not (meta-matches? (context-meta ctx) exclude))) contexts))
   (else
    (filter
     (lambda (ctx)
       (let ((meta (context-meta ctx)))
         (and (meta-matches? meta include)
              (not (meta-matches? meta exclude)))))
     contexts))))

(define (context-has-matching-examples? context #!key (include #f) (exclude #f))
  (not (null? (filter-examples context include exclude))))


(define (add-context-to-specification context)
  (returning context
    (*current-specification*
      (cons context (*current-specification*)))))

(define (filter-examples context include exclude)  
  (let ((examples (context-examples context)))
    (cond
     ((and (not include) (not exclude)) examples)
     ((not exclude)
      (filter
       (lambda (example)
         (meta-matches? (example-meta example) include))
       examples))
     ((not include)
      (filter
       (lambda (example)
         (not (meta-matches? (example-meta example) exclude)))
       examples))
     (else
      (filter (lambda (example)
                (let ((meta (example-meta example)))
                  (and (meta-matches? meta include)
                       (not (meta-matches? meta exclude)))))
              examples)))))




;; Contexts
;; =========
;; A context is a scope for examples
(defstruct context description examples hooks meta subject parent)
(define *current-context*   (make-parameter #f))

(define (create-context description #!key (examples (list)) (meta (list)))
  (make-context description: description examples: examples hooks: (list) meta: meta subject: #f parent: (*current-context*)))

(define-record-printer (context ctx out)
  (fprintf
      out
      "#<context '~A' parent: ~A subject: ~A meta: ~A examples: ~A>"
    (context-description ctx)
    (context-parent ctx)
    (context-subject ctx)
    (context-meta ctx)
    (length (context-examples ctx))))

(define (unspecified)
  (let ((intern 1))
    (set! intern 2)))

(define-syntax context
  (syntax-rules ()
    ((_ argument more-arguments ...)
     (describe argument more-arguments ...))))

(define-syntax describe
  (syntax-rules (meta)
    ((_ what)
     (add-context-to-specification
      (create-context what)))
    ((_ what (meta (tag value ...) ...))
     (add-context-to-specification
      (create-context what meta: '((tag value ...) ...))))
    ((_ what (meta (tag value ...) ...) example examples+ ...)
     (add-context-to-specification
      (call-with-context
       (create-context what meta: '((tag value ...) ...))
       (lambda () example examples+ ...))))
    ((_ what example examples+ ...)
     (add-context-to-specification
      (call-with-context
       (create-context what)
       (lambda ()  example examples+ ...))))))

(define (call-with-context context thunk)
  (parameterize ((*current-context* context))
    (returning (*current-context*)
       (thunk))))

(define (run-context context #!optional (reporter values) (include #f) (exclude #f))
  (reporter context mode: 'adhoc)
  (run-context-with-hooks context reporter include exclude))

(define (run-context-with-hooks context reporter include exclude)
  (let ((before-all  (find-context-hooks 'before 'all: context ))
        (after-all   (find-context-hooks 'after  'all: context ))
        (context-result #t))
    (parameterize (( *current-context* context))
      (call-with-hooks
       (lambda ()
         (for-each-example-in-context
          (lambda (example)
            (unless (run-example-with-hooks example context reporter)
              (set! context-result #f)))
          context
          include
          exclude))
       before-all
       after-all))
    context-result))

(define (for-each-example-in-context callback context include exclude)
  (for-each
   callback
   (reverse
    (cond
     ((and exclude include)
      (if (meta-matches? (context-meta context) include)
          (filter-examples context  #f exclude)
          (filter-examples context include exclude)))
     (include
      (if (meta-matches? (context-meta context) include)
          (filter-examples context #f exclude)
          (filter-examples context include #f)))
     (exclude     
      (filter-examples context #f exclude))
     (else  (context-examples context))))))

(define (run-example-with-hooks example context reporter)
  (reporter example mode: 'adhoc) 
  (let ((before-hooks-for-example (find-context-hooks-for-example 'before example context))
        (after-hooks-for-example  (find-context-hooks-for-example 'after  example context)))
    (call-with-hooks
     (lambda ()
       (let ((result (run-example example)))
         (reporter result mode: 'adhoc)
         (not (example-failed? result))))
     before-hooks-for-example
     after-hooks-for-example)))

(define (find-context-hooks type filter-exp context)
  (let ((hooks (all-hooks-with-parent-traversal context)))
    (map context-hook-hook
         (filter
          (lambda (hook)
            (and (eq? (context-hook-type hook) type )
                 (eq? (context-hook-filter hook) filter-exp)))
          hooks))))

(define (context-ancestors context)
  (let loop ((parent (context-parent context)) (ancestors '()))
    (cond
     ((not parent)  (append ancestors (list context)))
     (else (loop (context-parent parent) (cons parent ancestors))))))

(define (all-hooks-with-parent-traversal context)
  (append-map context-hooks (context-ancestors context)))

(define (subject-set! subject #!optional (context (*current-context*)))
  (when context
    (context-subject-set! context subject)))
                    
(define (subject)
  (when (*current-context*)
    (context-subject (*current-context*))))

;; State
;;=======================================

(define *state* (make-hash-table))

(define ($ variable #!key (default #f))
  (hash-table-ref/default *state* variable default))

(define (reset-state!)
  (hash-table-clear! *state*))

(define (set-state! key value)
  (hash-table-set! *state* key value))

(set! (setter $) set-state!)


;; Context-Hooks
;; =============
;; Hooks are procedures that are called at specific times
;; during the run of a context (before,after,...).
;; They typically hold setup and teardown code

(defstruct context-hook hook filter type)

(define-record-printer (context-hook hook out)
  (fprintf out
      "#<context-hook type(~A) filter(~A) hook(~A)>"
    (context-hook-type hook)
    (context-hook-filter hook)
    (context-hook-hook hook)))

(define-syntax before
  (syntax-rules (each: all:)
    ((_ each: code more-code ...)
     (add-hook-to-context (lambda () code more-code ...) type: 'before filter: 'each:))
    ((_ all: code more-code ...)
     (add-hook-to-context (lambda () code more-code ...) type: 'before filter: 'all:))
    ((_ filter code more-code ...)
     (add-hook-to-context (lambda () code more-code ...) type: 'before filter: '(filter)))))

(define-syntax after
  (syntax-rules (each: all:)
    ((_ each: code more-code ...)
     (add-hook-to-context (lambda () code more-code ...) type: 'after filter: 'each:))
    ((_ all: code more-code ...)
     (add-hook-to-context (lambda () code more-code ...) type: 'after filter: 'all:))
    ((_ filter code more-code ...)
     (add-hook-to-context (lambda () code more-code ...) type: 'after filter: '(filter)))))

(define (add-hook-to-context hook  #!key (filter each:) (type 'before) (context (*current-context*)))
  (context-hooks-set! context
                      (cons
                       (make-context-hook hook: hook
                                          filter: filter
                                          type: type)
                       (context-hooks context))))

(define (call-with-hooks thunk before after)
  (dynamic-wind
      (lambda () (for-each (cut apply <> (list)) before))
      thunk
      (lambda () (for-each (cut apply <> (list)) after))))

(define (find-context-hooks-for-example type example context)
  (let ((hooks (all-hooks-with-parent-traversal context))
        (meta  (example-meta example)))
    (map context-hook-hook
         (filter
          (lambda (hook)
            (and (eq? (context-hook-type hook) type)
                 (meta-matches? meta (context-hook-filter hook))))
          hooks))))

(define (meta-matches? meta tags)
  (or (eq? tags each:)
      ((tag-expression->filter tags) meta)))

(define ((tag-expression->filter tags) meta)
  (every (lambda (tag) (member tag meta)) tags))


;; Examples
;; =============
;; An example is a specific piece of behaviour that
;; is specified. Examples live within a context's scope

(define *current-exit-continuation* (make-parameter #f))

(defstruct example description behaviour pending meta spec-file)

(define (create-example description behaviour #!key (pending #f) (meta (list)) (context #f))
  (make-example description: description behaviour: behaviour pending: pending meta: meta context: context))

(define-record-printer (example ex out)
  (fprintf out "#<example '~A' meta(~A)>" (example-description ex) (example-meta ex)))

(define-syntax it
  (syntax-rules (meta should not)
    ((_ should matcher)
     (add-example-to-context
      (create-example (sprintf "should ~S" (quote matcher))
                      (lambda ()
                        (expect (subject) matcher)))))
    ((_ description)
     (add-example-to-context (create-example description #f pending: #t)))
    ((_ description (meta (tag value ...) ...))
     (add-example-to-context (create-example description #f pending: #t meta: '((tag value ...) ...))))
    ((_ description (meta (tag value ...) ...) code more-code ...)
     (add-example-to-context (create-example description
                                             (lambda () code more-code ...)
                                             meta: '((tag value ...) ...))))
    ((_ description code more-code ...)
     (add-example-to-context (create-example description
                                             (lambda () code more-code ...))))))

(define (add-example-to-context example #!optional (context (*current-context*)))
  (returning example
    (when context
      (example-spec-file-set! example (current-spec-file))
      (context-examples-set! context (cons example (context-examples context))))))

(define (format-condition-properties exn without)
  (let* ((cps (condition->list exn))
         (eps (remove (lambda (x) (memq (car x) without))
                      (or (alist-ref 'exn cps) '())))
         (cps (alist-update! 'exn eps cps)))
    (with-output-to-string
        (lambda ()
          (for-each 
           (lambda (cp)
             (printf "~A:~%" (car cp))
             (for-each (lambda (p)
                         (printf "  ~A: ~S~%" (car p) (cadr p)))
                       (cdr cp)))
           cps)))))

(define (run-example example)
  (let((behaviour (example-behaviour example))
       (result    (make-example-result status: 'succeeded example: example messages: '() spec-file: (example-spec-file example))))
    (parameterize ((*current-example-result* result))
      (cond
       ((example-pending example)
        (example-result-status-set! result 'pending))
       (else
        (call-with-current-continuation
         (lambda (exit)
           (handle-exceptions exn
               (begin
;                (signal exn)
                 (fail-current-example-with! (sprintf "Error: ~S~%~A"
                                                      ((condition-property-accessor 'exn 'message) exn)
                                                      (format-condition-properties exn '(message call-chain)))))
             (call-with-exit-handler behaviour (make-exit-handler exit result)))))))
       result)))

(define (call-with-exit-handler code handler)
  (parameterize ((*current-exit-continuation* handler))
    (code)))

(define (make-exit-handler exit result)
  (lambda (status)
    (example-result-status-set! result status)
    (exit #f)))

(define (pending)
  (when (*current-exit-continuation*)
    ((*current-exit-continuation*) 'pending)))

(define (fail-current-example-with! message)
  (let ((result (*current-example-result*)))
    (when result
      (example-result-status-set! result 'failed)
      (add-failure-to-example-result result message)
      (when (*current-exit-continuation*)
        ((*current-exit-continuation*) 'failed)))))

;; Example-Result
;; ===============
;; This is the result of an example run.
;; It holds statistics about the example run that is used by the reporting-module

(defstruct example-result status messages example spec-file)

(define *current-example-result*    (make-parameter #f))

(define (example-failed? result)
  ;(printf "~A~%" (example-result-messages result))
  (eq? 'failed (example-result-status result)))

(define (example-pending? result)
  (eq? 'pending (example-result-status result)))

(define (add-failure-to-example-result result message)
  (let ((messages (example-result-messages result)))
    (example-result-messages-set! result (append messages message))))

;; Expectation
;; ============
;; An expectation allows us to say what we want
;; a procedure/object to behave like

(define negative-expectation (make-parameter #f))


(define-syntax expect
  (syntax-rules ()
    ((_ form)
     (run-expectation
      (quote form)
      (delay #f)
      (make-matcher check: (lambda (_) form)
                    failure-message-generator: (lambda (_ subject negate)
                                                 (if negate
                                                     (sprintf "Expected ~S not to evaluate to true but it did" (quote form))
                                                     (sprintf "Expected ~S to be true but was false" (quote form)))))
      (negative-expectation)))
    ((_ subject matcher)
     (run-expectation (quote subject) (delay subject) matcher (negative-expectation)))))

(define-syntax do-not
  (syntax-rules ()
    ((_ expectation)
     (parameterize ((negative-expectation #t))
       expectation))))

(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)))))))))




(define (run-expectation form subject matcher #!optional (negate #f))
  (let ((check (matcher-check matcher)))
    (cond
     (negate
      (when (check subject)
        (fail-current-example-with! (generate-failure-message matcher form subject #t))))
     (else
      (unless (check subject)
        (fail-current-example-with! (generate-failure-message matcher form subject #f)))))))


;; Matcher
;; ===========
;; A matcher is responsible to check if a certain behaviour
;; is present. It's a check agains the existing behaviour.
;; Matchers do generate failure-messages if the expectation is not met

(defstruct matcher check failure-message-generator)

(define (generate-failure-message matcher form subject #!optional (negate #f))
  (let ((message-generator (matcher-failure-message-generator matcher)))
    (message-generator form subject negate)))

(define-syntax to
  (syntax-rules ()
    ((_ form)
     form)))

;; Common Matchers
(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)
     (make-matcher check: (lambda (subject)
                            (if (procedure? pred-or-value)
                                (pred-or-value (force subject))
                                (equal? pred-or-value (force subject))))
                   
                   failure-message-generator: (lambda (form subject negate)
                                                (if negate
                                                    (sprintf "Expected ~S not to be ~S" (force subject) (quote pred-or-value))
                                                    (sprintf "Expected ~S to be ~S" (force subject) (quote pred-or-value))))))
    ((_ pred value more-values ...)
     (make-matcher check: (lambda (subject)
                            (apply pred (list (force subject) value more-values ...)))
                   failure-message-generator: (lambda (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))))))))



(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)))))



;; Stubs
(define *current-stub-removers* (make-parameter (list)))

(define (stub! procedure stub)
  (let ((advice-id (advise 'around procedure (lambda (proc args) (apply stub args)))))
    (add-stub-remover! (lambda () (unadvise procedure advice-id)))))

(define (add-stub-remover! remover)
  (*current-stub-removers* (cons remover (*current-stub-removers*))))


(define (clear-stubs!)
  (for-each (lambda (remover) (remover)) (*current-stub-removers*))
  (*current-stub-removers* '()))

(define (returns argument . more-arguments)
  (lambda _
    (apply values argument more-arguments)))

(define-syntax with-stubs!
  (syntax-rules ()
    ((_ ((proc stub) ...) code more-code ...)
     (dynamic-wind
         (lambda ()
           (stub! proc stub)
           ...)
         (lambda () code more-code ...)
         (lambda () (clear-stubs!))))))



;; Reporter
;; =========
;; At some point we need to notify the programmer
;; about the state of her expectations.
;; The reporter is responsible for presenting the result
;; to the user

(define (make-standard-reporter #!key (report-port (current-output-port)))
  (let ((failed 0)
        (successful 0)
        (pending 0))
    (lambda (data #!key (mode 'adhoc))
      (if (eq? mode 'summary)
          (fprintf report-port "~%~%Total: ~A Successful: ~A Failed: ~A Pending: ~A ~%" (+ failed successful pending) successful failed pending))
      (cond
       ((context? data) #t)
       ((example? data) #t)
       ((example-result? data)
        (let ((example (example-result-example data)))
          (cond
           ((example-failed? data)
            (set! failed (+ 1 failed))
            (fprintf report-port "Failure: ~A~%" (example-result-messages data)))
           ((example-pending? data)
            (set! pending (+ 1 pending))
            (fprintf report-port "Pending: ~A~%"  (example-description example)))
           (else
            (set! successful (+ 1 successful))
            (fprintf report-port "Success: ~A~%" (example-description example))))
          (flush-output report-port)))))))

)