;;;; streams-primitive.scm
;;;; Kon Lovett, Apr '09

; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  All rights
; reserved.  Permission is hereby granted, free of charge, to any person obtaining a copy of
; this software and associated documentation files (the "Software"), to deal in the Software
; without restriction, including without limitation the rights to use, copy, modify, merge,
; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
; whom the Software is furnished to do so, subject to the following conditions: The above
; copyright notice and this permission notice shall be included in all copies or substantial
; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
; THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(module streams-primitive (;export
  ;; SRFI 41 primitive
  stream?
  stream-null stream-null?
  (stream-cons $$make-stream-pare) ;($$stream-eager $$stream-lazy $$stream-delay)
  stream-pair? stream-car stream-cdr
  stream-lambda ;($$stream-lazy)
  ;; Extras
  stream-occupied?
  ;; Common errors
  check-stream error-stream
  check-stream-occupied error-stream-occupied
  ;; WTF
  ($$stream-lazy $$make-stream-lazy)
  ($$stream-eager $$make-stream-eager)
  $$stream-delay ;($$stream-lazy $$stream-eager)
  $$make-stream-lazy
  $$make-stream-eager
  $$make-stream-pare)

  (import scheme chicken
    (only type-checks define-check+error-type)
    (only type-errors define-error-type)
    srfi-9-ext)

  (require-library type-checks type-errors srfi-9-ext)

  (include "chicken-primitive-object-inlines")
  (include "streams-inlines")

;;;

(define-record-type/primitive stream
  (make-stream prm)
  stream?
  (prm stream-promise stream-promise-set!) )

(define-check+error-type stream)

(define (make-stream-box tag obj) (%cons tag obj))
(define (stream-box-tag box) (%car box))
(define (stream-box-value box) (%cdr box))
(define (stream-box-tag-set! box tag) (%set-car!/immediate box tag))
(define (stream-box-value-set! box val) (%set-cdr! box val))

(define ($$make-stream-lazy thunk) (make-stream (make-stream-box 'lazy thunk)))
(define ($$make-stream-eager obj) (make-stream (make-stream-box 'eager obj)))

(define (*stream-null? strm) (eq? (stream-force strm) (stream-force stream-null)))

;;;

(define-syntax $$stream-lazy
  (syntax-rules ()
    ((_ EXPR) ($$make-stream-lazy (lambda () EXPR)) ) ) )

(define-syntax $$stream-eager
  (syntax-rules ()
    ((_ EXPR) ($$make-stream-eager EXPR) ) ) )

(define-syntax $$stream-delay
  (syntax-rules ()
    ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)) ) ) )

(define (stream-force promise)
  (let ((content (stream-promise promise)))
    (case (stream-box-tag content)
      ((eager)
        (stream-box-value content) )
      ((lazy)
        (let* ((promise* ((stream-box-value content)))
               (content  (stream-promise promise)))
          (unless (eq? 'eager (stream-box-tag content))
            (let ((prm (stream-promise promise*)))
              (stream-box-tag-set! content (stream-box-tag prm))
              (stream-box-value-set! content (stream-box-value prm)) )
            (stream-promise-set! promise* content) )
         (stream-force promise) ) ) ) ) )

(define stream-null ($$stream-delay (%cons 'stream 'null)))

(define (stream-null? obj) (and (%stream? obj) (*stream-null? obj)))
(define (stream-occupied? obj) (and (%stream? obj) (not (*stream-null? obj))))

(define-check+error-type stream-occupied)

(define-syntax stream-lambda
  (syntax-rules ()
    ((_ FORMALS BODY0 BODY1 ...)
     (lambda FORMALS ($$stream-lazy (let () BODY0 BODY1 ...))) ) ) )

;;

(define-record-type/primitive stream-pare
  ($$make-stream-pare kar kdr)
  stream-pare?
  (kar stream-kar)
  (kdr stream-kdr) )

(define-error-type stream-pair)

(define (checked-stream-pare loc obj)
  (cond
    ((not (%stream? obj)) (error-stream loc obj 'stream) )
    ((*stream-null? obj) (error-stream-occupied loc obj 'stream) )
    (else
      (let ((val (stream-force obj)))
        (if (stream-pare? val) val
            (error-stream-pair loc val 'stream)) ) ) ) )

(define-syntax stream-cons
  (syntax-rules ()
    ((_ EXPR STRM)
     ($$stream-eager ($$make-stream-pare ($$stream-delay EXPR) ($$stream-lazy STRM))) ) ) )

(define (stream-pair? obj) (and (%stream? obj) (stream-pare? (stream-force obj))))

(define (stream-car streem)
  (stream-force (stream-kar (checked-stream-pare 'stream-car streem))) )

(define (stream-cdr streem)
  (stream-kdr (checked-stream-pare 'stream-cdr streem)) )

) ;module streams-primitive