#lang mzscheme

(require-for-syntax (file "../syntax.ss"))

(require scheme/contract
         scheme/match
         (only srfi/1/list append-map filter filter-map)
         srfi/26/cut)

(require (file "../base.ss")
         (file "../list.ss"))

; Result structures ----------------------------

(define-struct check-result (message annotations) #f)
(define-struct (check-problem check-result) () #f)
(define-struct (check-success check-result) () #f)
(define-struct (check-failure check-problem) () #f)
(define-struct (check-warning check-problem) () #f)
(define-struct (check-error   check-problem) (exn) #f)

;; check-result-exn : check-result -> (U exn #f)
(define (check-result-exn result)
  (if (check-error? result)
      (check-error-exn result)
      #f))

; Result constructors --------------------------

;; pass : -> (list check-success)
(define (pass)
  (list (make-check-success "Okay" null)))

;; fail : string -> (list check-failure)
(define (fail message)
  (list (make-check-failure message null)))

;; warn : string -> (list check-warning)
(define (warn message)
  (list (make-check-warning message null)))

;; check-with-handlers : (-> (list-of check-result)) -> (list-of check-result)
(define (check-with-handlers thunk)
  (with-handlers ([exn? (lambda (exn)
                          (list (make-check-error "Exception raised" null exn)))])
    (thunk)))

; Result list combinators ----------------------

;; check-all : (list-of check-result) ... -> (list-of check-result)
(define check-all append)

;; check-with-annotations : (alist-of symbol any) (list-of check-result) -> (list-of check-result)
(define (check-with-annotations annotations results)
  (map (cut annotate-check-result <> annotations)
       results))

;; check-until-problems : (-> (list-of check-result)) ... -> (list-of check-results)
(define check-until-problems
  (match-lambda*
    [(list) null]
    [(list-rest head tail)
     (let* ([results  (head)]
            [problems (check-results->problems results)])
       (if (null? problems)
           (apply check-until-problems tail)
           results))]))

;; check-problems? : (list-of check-result) -> boolean
(define (check-problems? results)
  (ormap check-problem? results))

;; check-results->problems : (list-of check-result) -> (list-of (U check-warning check-failure check-error))
(define (check-results->problems results)
  (define-values (warnings failures errors)
    (check-results->warnings+failures+errors results))
  (append errors failures warnings))

;; check-results->warnings+failures+errors
;;     : (list-of check-result)
;;    -> (values (list-of check-warning)
;;               (list-of check-failure)
;;               (list-of check-error))
(define (check-results->warnings+failures+errors results)
  (let loop ([results results]
             [warnings null]
             [failures null]
             [errors null])
    (match results
      [(list)
       (values (reverse warnings)
               (reverse failures)
               (reverse errors))]
      [(list-rest (? check-success? result) other)
       (loop other 
             warnings
             failures
             errors)]
      [(list-rest (? check-warning? result) other)
       (loop other 
             (cons result warnings)
             failures
             errors)]
      [(list-rest (? check-failure? result) other)
       (loop other 
             warnings
             (cons result failures)
             errors)]
      [(list-rest (? check-error? result) other)
       (loop other 
             warnings
             failures
             (cons result errors))])))

; Annotations ----------------------------------

;; check-result-annotation : check-result symbol -> boolean
(define (check-result-annotation? result key)
  (if (assoc key (check-result-annotations result))
      #t
      #f))

;; check-result-annotation : check-result symbol -> any
(define (check-result-annotation result key)
  (assoc-value key (check-result-annotations result)))

;; check-result-annotation : check-result symbol any -> any
(define (check-result-annotation/default result key default)
  (assoc-value/default key (check-result-annotations result) default))

;; annotate-check-result : check-result (alist-of symbol any) -> check-result
(define (annotate-check-result result annotations)
  (let ([message (check-result-message result)]
        [annotations (alist-merge (check-result-annotations result) annotations 'second)])
    (cond [(check-success? result) (make-check-success message annotations)]
          [(check-failure? result) (make-check-failure message annotations)]
          [(check-warning? result) (make-check-warning message annotations)]
          [(check-error? result)   (make-check-error   message annotations (check-error-exn result))])))

; Provide statmenets ---------------------------

(provide/contract
 [struct check-result                     ([message string?] [annotations (listof (cons/c symbol? any/c))])]
 [struct (check-success check-result)     ([message string?] [annotations (listof (cons/c symbol? any/c))])]
 [struct (check-problem check-success)    ([message string?] [annotations (listof (cons/c symbol? any/c))])]
 [struct (check-warning check-problem)    ([message string?] [annotations (listof (cons/c symbol? any/c))])]
 [struct (check-failure check-problem)    ([message string?] [annotations (listof (cons/c symbol? any/c))])]
 [struct (check-error   check-problem)    ([message string?] [annotations (listof (cons/c symbol? any/c))] [exn exn?])]
 
 [check-result-exn                        (-> check-result? (or/c exn? false/c))]
 
 [pass                                    (-> (list/c check-success?))]
 [fail                                    (-> string? (list/c check-failure?))]
 [warn                                    (-> string? (list/c check-warning?))]
 
 [check-all                               (->* () () #:rest (listof (listof check-result?)) (listof check-result?))]
 [check-with-handlers                     (-> (-> (listof check-result?)) (listof check-result?))]
 [check-with-annotations                  (-> (listof (cons/c symbol? any/c)) (listof check-result?) (listof check-result?))]
 [check-until-problems                    (->* () () #:rest (listof procedure?) (listof check-problem?))]
 
 [check-problems?                         (-> (listof check-result?) boolean?)]
 [check-results->problems                 (-> (listof check-result?) (listof check-problem?))]
 [check-results->warnings+failures+errors (-> (listof check-result?)
                                              (values (listof check-warning?)
                                                      (listof check-failure?)
                                                      (listof check-error?)))]
 
 
 [check-result-annotation?                (-> check-result? symbol? boolean?)]
 [check-result-annotation                 (-> check-result? symbol? any/c)]
 [check-result-annotation/default         (-> check-result? symbol? any/c any/c)]
 [annotate-check-result                   (-> check-result? (listof (cons/c symbol? any/c)) check-result?)])