(define-module (knots)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (fibers conditions)
  #:use-module (system repl debug)
  #:export (call-with-default-io-waiters

            wait-when-system-clock-behind

            call-with-sigint

            &knots-exception
            make-knots-exception
            knots-exception?
            knots-exception-stack

            print-backtrace-and-exception/knots))

(define (call-with-default-io-waiters thunk)
  (parameterize
      ((current-read-waiter (@@ (ice-9 suspendable-ports)
                                default-read-waiter))
       (current-write-waiter (@@ (ice-9 suspendable-ports)
                                 default-write-waiter)))
    (thunk)))

(define (wait-when-system-clock-behind)
  (let ((start-of-the-year-2000 946684800))
    (while (< (current-time)
              start-of-the-year-2000)
      (simple-format (current-error-port)
                     "warning: system clock potentially behind, waiting\n")
      (sleep 20))))

;; Copied from (fibers web server)
(define (call-with-sigint thunk cvar)
  (let ((handler #f))
    (dynamic-wind
      (lambda ()
        (set! handler
          (sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
      thunk
      (lambda ()
        (if handler
            ;; restore Scheme handler, SIG_IGN or SIG_DFL.
            (sigaction SIGINT (car handler) (cdr handler))
            ;; restore original C handler.
            (sigaction SIGINT #f))))))

(define &knots-exception
  (make-exception-type '&knots-exception
                       &exception
                       '(stack)))

(define make-knots-exception
  (record-constructor &knots-exception))

(define knots-exception?
  (exception-predicate &knots-exception))

(define knots-exception-stack
  (exception-accessor
   &knots-exception
   (record-accessor &knots-exception 'stack)))

(define* (print-backtrace-and-exception/knots
          exn
          #:key (port (current-error-port)))
  (let* ((stack (match (fluid-ref %stacks)
                  ((stack-tag . prompt-tag)
                   (make-stack #t
                               0 prompt-tag
                               0 (and prompt-tag 1)))))
         (error-string
          (call-with-output-string
            (lambda (port)
              (let ((knots-stacks
                     (map knots-exception-stack
                          (filter knots-exception?
                                  (simple-exceptions exn)))))

                (let ((stack-vec
                       (stack->vector stack)))
                  (print-frames (list->vector
                                 (drop
                                  (vector->list stack-vec)
                                  6))
                                port
                                #:count (stack-length stack)))
                (for-each
                 (lambda (stack)
                   (let ((stack-vec
                          (stack->vector stack)))
                     (print-frames (list->vector
                                    (drop
                                     (vector->list stack-vec)
                                     3))
                                   port
                                   #:count (stack-length stack))))
                 knots-stacks)
                (print-exception
                 port
                 (if (null? knots-stacks)
                     (stack-ref stack 1)
                     (stack-ref (last knots-stacks) 3))
                 '%exception
                 (list exn)))))))
    (display error-string port)))