;; 
;; %%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  to
  make-matcher
  matcher
 
  *current-context* context-subject-set!
  $ reset-state!
  current-spec-file
  negative-expectation
  do-not
  unspecified

  )

(import chicken scheme extras data-structures ports)
(require-library defstruct srfi-1 regex 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 (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)))

(define-syntax matcher
  (syntax-rules (check message)
    ((_ (check (subject) code more-code ...)
        (message (form message-subject negate) msg-code more-msg-code ...))
     (make-matcher
      check: (lambda (subject) code more-code ...)
      failure-message-generator: (lambda (form message-subject negate) msg-code more-msg-code ...)))))

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

)