#lang racket/base
(require "private/promise.rkt" (for-syntax racket/base syntax/for-body))
(provide delay lazy force promise? promise-forced? promise-running? promise/name?
         (rename-out [delay/name* delay/name]
                     [delay/strict* delay/strict]
                     [delay/sync* delay/sync]
                     [delay/thread* delay/thread]
                     [delay/idle* delay/idle])
         for/list/concurrent
         for*/list/concurrent)

;; ----------------------------------------------------------------------------
;; More delay-like values, with different ways of deferring computations

(define-struct (promise/name promise) ()
  #:property prop:force (λ(p) ((pref p))))
(define delay/name make-promise/name)
(define-syntax delay/name* (delayer #'delay/name '()))

;; mostly to implement srfi-45's `eager'
(define-struct (promise/strict promise) ()
  #:property prop:force (λ(p) (reify-result (pref p)))) ; never a thunk
(define (delay/strict thunk)
  ;; could use `reify-result' here to capture exceptions too, or just create a
  ;; promise and immediately force it, but no point since if there's an
  ;; exception then the promise value is never used.
  (make-promise/strict (call-with-values thunk list)))
(define-syntax delay/strict* (delayer #'delay/strict '()))

;; utility struct
(define-struct (running-thread running) (thread))

;; used in promise/sync until it's forced
(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema)
  ;; We don't want to apply a `syncinfo`, but declaring the `syncinfo`
  ;; as a procedure tells `promise-forced?` when the promise is not
  ;; yet forced
  #:property prop:procedure (case-lambda)
  #:property prop:running? (lambda (o) (running-thread? (syncinfo-thunk o))))

(define-struct (promise/sync promise) ()
  #:property prop:custom-write
  (λ(p port write?)
    (define v (pref p))
    (promise-printer (if (syncinfo? v) (make-promise (syncinfo-thunk v)) p)
                     port write?))
  #:property prop:force
  (λ(p)
    (define v (pref p))
    (reify-result
     (cond
       ;; already forced
       [(not (syncinfo? v)) v]
       ;; being forced...
       [(running-thread? (syncinfo-thunk v))
        ;; Note: after `(syncinfo-thunk v)' changes to a `running-thread'
        ;; instance, it doesn't change again, so we can assume that it's still
        ;; a `running-thread' instance.
        (define r (syncinfo-thunk v))
        (if (eq? (running-thread-thread r) (current-thread))
          ;; ... by the current thread => throw the usual reentrant error
          (r)
          ;; ... by a different thread => just wait for it
          (begin (sync (syncinfo-done-evt v)) (pref p)))]
       [else
        ;; wasn't forced yet: try to do it now
        (call-with-semaphore (syncinfo-access-sema v)
          (λ(p v) ; pass `p' and `v' to avoid closure allocation
            (define thunk (syncinfo-thunk v))
            (define done (syncinfo-done-sema v))
            ;; Now that we've taken the lock, check thunk' again:
            (unless (running-thread? thunk)
              ;; set the thread last
              (set-syncinfo-thunk!
               v (make-running-thread (object-name thunk) (current-thread)))
              (call-with-exception-handler
               (λ(e) (pset! p (make-reraise e))
                     (semaphore-post done)
                     e)
               (λ()  (pset! p (call-with-values thunk list))
                     (semaphore-post done)))))
          #f
          p v)
        ;; whether it was this thread that forced it or not, the results are
        ;; now in
        (pref p)])))
  #:property prop:evt
  (λ(p) (define v (pref p))
        (wrap-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void)))

(define (delay/sync thunk)
  (define done-sema (make-semaphore 0))
  (make-promise/sync (make-syncinfo thunk
                                    (semaphore-peek-evt done-sema) done-sema
                                    (make-semaphore 1))))
(define-syntax delay/sync* (delayer #'delay/sync '()))

;; threaded promises

(define-struct (promise/thread promise) ()
  #:property prop:force
  (λ(p) (define v (pref p))
        (reify-result
         (if (running-thread? v)
           (let ([t (running-thread-thread v)])
             (thread-wait t)
             (define v (pref p))
             (if (running-thread? v)
               (error 'force "promise's thread terminated ~a\n  promise: ~e"
                      "without result or exception" p)
               v))
           v)))
  #:property prop:evt
  (λ(p) (define v (pref p))
        (wrap-evt (if (running? v) (running-thread-thread v) always-evt)
                  void)))

(define (delay/thread thunk group)
  (unless (or (not group)
              (thread-group? group))
    (raise-argument-error 'delay/thread "(or/c thread-group? #f)" group))
  (define initialized-sema (make-semaphore))
  (define orig-c (current-custodian))
  (define (run)
    (semaphore-wait initialized-sema) ; wait until p is properly defined
    (call-with-exception-handler
     (λ (e)
       (pset! p (make-reraise e))
       (parameterize ([current-custodian orig-c])
         (kill-thread (current-thread))))
     (λ () (pset! p (call-with-values thunk list)))))
  (define p
    (make-promise/thread
     (make-running-thread
      (object-name thunk)
      (if group
          (parameterize ([current-thread-group group]) (thread run))
          (thread run)))))
  ;; The promise thread needs to wait until `p' is defined and assigned its
  ;; value, otherwise the `run' thread can start when `p' is still
  ;; #<undefined>, and end up doing `unsafe-struct-set!' on it.  This was the
  ;; cause of an intermittent failure in the Typed Racket test suite.
  (semaphore-post initialized-sema)
  p)
(define-syntax delay/thread*
  (delayer #'delay/thread (list (cons '#:group #'(make-thread-group)))))

(define-struct (promise/idle promise/thread) ()
  #:property prop:force
  (λ(p) (define v (pref p))
        (reify-result
         (if (procedure? v)
           ;; either running-thread, or returns the controller
           (let ([controller (if (running-thread? v)
                               (running-thread-thread v)
                               (v))])
             (thread-send controller 'force!)
             (thread-wait controller)
             (pref p))
           v))))

(define (delay/idle thunk wait-for work-while tick use*)
  (unless (evt? wait-for)
    (raise-argument-error 'delay/idle "evt?" wait-for))
  (unless (evt? work-while)
    (raise-argument-error 'delay/idle "evt?" work-while))
  (unless (and (real? tick) (not (negative? tick)))
    (raise-argument-error 'delay/idle "(>=/c 0.0)" tick))
  (unless (real? use*)
    (raise-argument-error 'delay/idle "real?" use*))
  (define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
  (define work-time (* tick use))
  (define rest-time (- tick work-time))
  (define orig-c (current-custodian))
  (define (work)
    (call-with-exception-handler
     (λ (e)
       (pset! p (make-reraise e))
       (parameterize ([current-custodian orig-c])
         (kill-thread (current-thread))))
     (λ () (pset! p (call-with-values thunk list)))))
  (define (run)
    ;; this thread is dedicated to controlling the worker thread, so it's
    ;; possible to dedicate messages to signaling a `force'.
    (define force-evt (thread-receive-evt))
    (sync wait-for force-evt)
    (pset! p (make-running-thread (object-name thunk) controller-thread))
    (define worker (parameterize ([current-thread-group (make-thread-group)])
                     (thread work)))
    (cond
      [(and (use . >= . 1) (equal? work-while always-evt))
       ;; as if it was pre-forced
       (thread-wait worker)]
      [(use . <= . 0)
       ;; work only when explicitly forced
       (thread-suspend worker)
       (sync force-evt)
       (thread-wait worker)]
      [else
       (thread-suspend worker)
       (let loop ()
         ;; rest, then wait for idle time, then resume working
         (if (eq? (begin0 (or (sync/timeout rest-time force-evt)
                              (sync work-while force-evt))
                    (thread-resume worker))
                  force-evt)
           ;; forced during one of these => let it run to completion
           (thread-wait worker)
           ;; not forced
           (unless (sync/timeout work-time worker)
             (thread-suspend worker)
             (loop))))]))
  ;; I don't think that a thread-group here is needed, but it doesn't hurt
  (define controller-thread
    (parameterize ([current-thread-group (make-thread-group)])
      (thread run)))
  ;; the thunk is not really used in the above, make it a function that returns
  ;; the controller thread so it can be forced (used in the `prop:force')
  (define p (make-promise/idle
             (procedure-rename (λ() controller-thread)
                               (or (object-name thunk) 'idle-thread))))
  p)
(define-syntax delay/idle*
  (delayer #'delay/idle (list (cons '#:wait-for   #'(system-idle-evt))
                              (cons '#:work-while #'(system-idle-evt))
                              (cons '#:tick       #'0.2)
                              (cons '#:use        #'0.12))))

(define-syntaxes (for/list/concurrent for*/list/concurrent)
  (let ()
    (define ((make-transformer for/fold/derived-stx [orig-stx #f]) stx)
      (syntax-case stx ()
        [(_ #:group group-expr clauses body ...)
         (let ([stx (or orig-stx stx)])
           (with-syntax ([this-syntax stx]
                         [for/fold/derived for/fold/derived-stx]
                         [((pre-body ...)
                           (post-body ...))
                          (split-for-body stx #'(body ...))])
             (syntax/loc stx
               (let ([group group-expr])
                 (for/fold/derived this-syntax
                   ([promises null] #:result (map force (reverse promises)))
                   clauses
                   pre-body ...
                   (cons (delay/thread*
                          #:group group
                          (let () post-body ...))
                         promises))))))]
        [(_ clauses body ...)
         ((make-transformer for/fold/derived-stx stx)
          #'(fc #:group (make-thread-group) clauses body ...))]))
    (values
     (make-transformer #'for/fold/derived)
     (make-transformer #'for*/fold/derived))))
