(define-module (doctest evaluate)
    #:export (sexp->module module-run-doctests run-doctests))
(use-modules (ice-9 match))
(use-modules (doctest util))
(use-modules (doctest docstring))

(define (sexp->module sexp)
    "
	Return module, associated in SEXP, #f otherwise.
        If SEXP is string, read from before.
    "
    (if (string? sexp)
	(sexp->module (read (open-input-string sexp)))
	(and (list? sexp)
	     (not (null? sexp))
	     (resolve-module sexp #:ensure #f))))

(define (values->string objs)
    (define (show obj) (format #f "~a" obj))
    (match objs
	   ([] "*unspecified*")
	   ([single] (format #f "~a" single))
	   ([val ...] (format #f "(values ~a)"
			      (string-join (map show val))))))

(define* (run-doctests tests #:key context)
    (define len (length tests))
    (when context
	  (set-current-module context))
    (for [(index . (test . expects)) as _ in (enumerate tests #:init 1)]
	 (define (display-expectations test expects)
	     (format #t "Error when evaluating ~a" test)
	     (format #t "\n    Expected: ~a" (values->string expects)))
	 (format #t "\n  [~a/~a]..." index  len)
	 (catch #t
		(begin-proc
		 (call-with-values (begin-proc (eval test (current-module)))
		     (lambda ( . results)
			 (if (equal? results expects)
			     (format #t "ok")
			     (begin (display-expectations test expects)
				    (format #t "\n    Received: ~a"
					    (values->string results)))))))
		(lambda ( . args)
		    (display-expectations test expects)
		    (format #t "\n    Caught: ~a" args)))))

(define (module-run-doctests module)
    (set-current-module module)
    (for [(name => var) in (module-obarray (current-module))]
	 (define value (variable-ref var))
	 (when [procedure? value]
	       (let* ((docstring (procedure-documentation value))
		      (tests (and (string? docstring)
				  (docstring->doctests docstring))))
		   (format #t " Tesing ~a... " name)
		   (cond
		    [(not docstring) (display "undocumented\n")]
		    [(null? tests)   (display "no tests\n")]
		    [else            (run-doctests tests)
				     (newline)])))))
