;;; Chickadee Game Toolkit
;;; Copyright © 2017 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (chickadee scripting script)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:export (script?
            script-cancelled?
            script-running?
            script-complete?
            spawn-script
            script
            cancel-script
            yield
            join)
  #:replace (yield))

(define-record-type <script>
  (make-script status children joined)
  script?
  (status script-status set-script-status!)
  (children script-children set-script-children!)
  (joined script-joined set-script-joined!))

(define current-script (make-parameter #f))

(define (display-script script port)
  (format port "<script status: ~a>" (script-status script)))

(set-record-type-printer! <script> display-script)

(define (script-cancelled? script)
  "Return #t if SCRIPT has been cancelled."
  (eq? 'cancelled (script-status script)))

(define (script-running? script)
  "Return #t if SCRIPT has not yet terminated or been cancelled."
  (eq? 'running (script-status script)))

(define (script-complete? script)
  "Return #t if SCRIPT has terminated."
  (eq? 'complete (script-status script)))

(define (script-terminated? script)
  "Return #t if SCRIPT is in either the completed or cancelled state."
  (or (script-complete? script) (script-cancelled? script)))

(define (cancel-script script)
  "Prevent further execution of SCRIPT."
  (set-script-status! script 'cancelled)
  (for-each cancel-script (script-children script))
  (resume-joined-scripts script))

(define (add-join! script cont)
  "Add CONT to the list of continuations waiting for SCRIPT to finish."
  (set-script-joined! script (cons cont (script-joined script))))

(define (resume-joined-scripts script)
  "Resume all scripts waiting on SCRIPT to terminate."
  (for-each (lambda (cont) (cont))
            (script-joined script)))

(define script-prompt (make-prompt-tag 'script))

(define (spawn-script thunk)
  "Apply THUNK as a script."
  (let ((script (make-script 'running '() '())))
    (define (handler cont callback . args)
      (define (resume . args)
        ;; Call the continuation that resumes the script, unless the
        ;; script has been cancelled in the meanwhile.
        (unless (script-cancelled? script)
          (call-with-prompt script-prompt
            (lambda () (apply cont args))
            handler)))
      (when (procedure? callback)
        (apply callback resume args)))
    (define task
      (let ((dynamic-state (current-dynamic-state)))
        (lambda ()
          (with-dynamic-state
           dynamic-state
           (lambda ()
             (current-script script)
             (thunk)
             (set-script-status! script 'complete)
             (resume-joined-scripts script))))))
    ;; Register child script with parent.  Cancelling the parent will
    ;; cause all children to be cancelled as well.
    (when (script? (current-script))
      (set-script-children! (current-script)
                            (cons script (script-children (current-script)))))
    ;; Start the script.
    (call-with-prompt script-prompt task handler)
    script))

(define-syntax-rule (script body ...)
  "Evaluate BODY in a script."
  (spawn-script (lambda () body ...)))

(define (yield handler)
  "Suspend the current script and pass its continuation to the
procedure HANDLER."
  (abort-to-prompt script-prompt handler))

(define (join script)
  "Suspend the current script until SCRIPT has terminated."
  (unless (script-terminated? script)
    (yield (lambda (cont)
             (add-join! script cont)))))