;;;; streams.primitive.scm  -*- Scheme -*-

; 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
  stream-pair?
  stream-car
  stream-cdr
  stream-lambda
  ;extras
  stream-occupied?
  check-stream
  error-stream
  check-stream-occupied
  error-stream-occupied
  ;explicit export: compiler cannot follow syntax >-> syntax
  $stream-lazy$
  $stream-eager$
  $stream-delay$
  $make-stream-lazy$
  $make-stream-eager$
  $make-stream-pair$)

(import scheme
  (chicken base)
  (chicken syntax)
  type-checks
  type-errors
  record-variants)

;;;

;; ensure identifier defined
(define stream 'stream)
(define-record-type-variant stream (unsafe unchecked inline)
  (%make-stream prom)
  (%stream?)
  (prom %stream-promise %stream-promise-set!) )

(define-inline (stream-tagged-pair? obj)
  (and
    (pair? obj)
    (let ((tag (car obj)))
      (or (eq? 'lazy tag) (eq? 'eager tag)) ) ) )

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

(define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
(define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))

(define-inline (stream-lazy-box? obj) (eq? 'lazy (stream-box-tag obj)))
(define-inline (stream-eager-box? obj) (eq? 'eager (stream-box-tag obj)))

(define-inline (check-stream-box loc obj)
  (unless (stream-tagged-pair? obj)
    (error-argument-type loc obj "stream-box") )
  obj )

(define (stream-print obj out)
  (display "#<" out)
  (let ((promise (%stream-promise obj)))
    (cond
      ((stream-eager-box? promise)  (display "eager stream" out))
      ((stream-lazy-box? promise)   (display "lazy stream" out))
      (else
        (display "unknown stream " out) (display promise out)) ) )
  (display ">" out) )

;;;

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

(define-syntax $stream-lazy$
  (syntax-rules ()
    (($stream-lazy$ ?expr)
      ($make-stream-lazy$ (lambda () ?expr)) ) ) )

(define-syntax $stream-eager$
  (syntax-rules ()
    (($stream-eager$ ?expr)
      ($make-stream-eager$ ?expr) ) ) )

(define-syntax $stream-delay$
  (syntax-rules ()
    (($stream-delay$ ?expr)
      ($stream-lazy$ ($stream-eager$ ?expr)) ) ) )

;;;

(define (stream? obj) (%stream? obj))

(define-check+error-type stream)

(define (stream-force prom)
  (let* (
    (content (%stream-promise (check-stream #f prom)))
    (promise-box-value (stream-box-value content)) )
    ;better be there! (check-stream-box #f content)
    (case (stream-box-tag content)
      ((eager)
        promise-box-value )
      ((lazy)
        (let* (
          (prom* (promise-box-value))
          ;re-fetch promise in case changed by recursion via above call.
          (content (%stream-promise prom)) )
          ;re-establish bona-fides
          (check-stream #f prom*)
          ;better be there! (check-stream-box #f content)
          (unless (eq? 'eager (stream-box-tag content))
            (let ((content* (%stream-promise prom*)))
              (stream-box-tag-set! content (stream-box-tag content*))
              (stream-box-value-set! content (stream-box-value content*)) )
            (%stream-promise-set! prom* content) )
          (stream-force prom) ) ) ) ) )

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

(define-inline (*stream-null? strm)
  (eq? (stream-force strm) (stream-force 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 ()
    ((stream-lambda ?formals ?body0 ?body1 ...)
     (lambda ?formals ($stream-lazy$ (let () ?body0 ?body1 ...))) ) ) )

;;

;; ensure identifier defined
(define stream-pair 'stream-pair)
(define-record-type-variant stream-pair (unsafe unchecked inline)
  (%make-stream-pair hd tl)
  (%stream-pair?)
  (hd %stream-car)
  (tl %stream-cdr) )

;want inline car/cdr but need exportable procedure for make.
(define ($make-stream-pair$ hd tl) (%make-stream-pair hd tl))

(define-error-type stream-pair)

(define-inline (checked-stream-pair 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-pair? val)
          val
          (error-stream-pair loc val 'stream)) ) ) ) )

(define (stream-pair-print obj out)
  (display "#<" out)
  (display (%stream-car obj) out)
  (display " " out)
  (display (%stream-cdr obj) out)
  (display ">" out) )

(define-syntax stream-cons
  (syntax-rules ()
    ((_ ?expr ?strm)
      ($stream-eager$ ($make-stream-pair$ ($stream-delay$ ?expr) ($stream-lazy$ ?strm))) ) ) )

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

(define (stream-car strm)
  (stream-force (%stream-car (checked-stream-pair 'stream-car strm))) )

(define (stream-cdr strm)
  (%stream-cdr (checked-stream-pair 'stream-cdr strm)) )

;;;

(set! (record-printer stream) stream-print)

(set! (record-printer stream-pair) stream-pair-print)

) ;module (streams primitive)