goof-loop/goof.scm

;; goof loop - a bastardisation of chibi loop.
;;
;; Copyright 2020, 2021 Linus Björnstam
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. The name of the author(s) may not be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;; This is a looping construct obviously based on (chibi loop) (aka:
;; foof-loop) by Alex Shinn. The name goof-loop is a play on that
;; name, and the fact that I goofed in the chibi issue tracker when
;; trying to understand the iterator protocol.

(define-module (goof)
  #:use-module (goof helpers)
  #:use-module (goof ref-let)
  #:use-module ((srfi srfi-1) #:select (circular-list))
  #:use-module ((srfi srfi-43) #:select (vector-copy vector-copy!))
  #:use-module (srfi srfi-71)
  #:use-module (rnrs io simple)
  #:use-module (ice-9 futures)
  #:export (loop
            
            loop/list
            loop/sum
            loop/product
            loop/first
            loop/last
            loop/and
            loop/or
            loop/list/parallel
            
            :when :unless :break :final :let :let* :subloop :for :acc
            :length :fill

            in
            in-list
            in-lists

            in-vector in-reverse-vector
            in-string in-reverse-string
            in-hash

            in-port
            in-file
            in-generator
            up-from
            down-from
            accumulating
            folding
            listing
            listing-reverse
            appending
            appending-reverse
            summing
            multiplying
            hashing
            vectoring

            in-cycle
            in-indexed
            ))

;; This contains the portable parts of goof-loop.
(include "goof-impl.scm")

;; Helper procedures for let-kw-form
(define (syntax= s1 s2)
  (equal? (syntax->datum s1) (syntax->datum s2)))

(define (update-name params name val)
  (cond
   ((null? params) (error "unknown loop variable name " name (list '=> name val)))
   ((syntax= name (caar params))
    (cons (list (caar params) val) (cdr params)))
   (else
    (cons (car params) (update-name (cdr params) name val)))))


(define-syntax inner-recur
  (syntax-rules ()
    ((_ loop-name final-fun () ((v s) ...))
     (loop-name s ...))
    ((_ loop-name final-fun (user-finals ...) ((v s) ...))
     (let ((v s) ...)
       (if (or user-finals ...)
           final-fun
           (loop-name v ...))))))

     
(define (syntax->list stx)
  (syntax-case stx ()
    ((a ...) #'(a ...))))


(define-syntax let-kw-form
  (syntax-rules ()
    ((_ macro-name final-fun (user-finals ...) (loop-name (var step) ...) . body)
     (let-syntax ((macro-name
                   (lambda (stx)
                     (with-ellipsis :::
                       (let loop ((lst (cdr (syntax->list stx)))
                                  (params (list #'(var step) ...)))
                         (if (null? lst)
                             (with-syntax ((((v s) :::) params))
                               #'(inner-recur loop-name final-fun
                                              (user-finals ...)
                                              ((v s) :::)))
                             (syntax-case (car lst) (=>)
                               ((=> name val)
                                (loop (cdr lst) (update-name params #'name #'val)))
                               (_ (error "Malformed looping clause in macro")))))))))
       . body))))



(define-syntax loop/list/parallel
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             parallel-list-loop
             () (clauses ... (%acc futures (listing-reverse (future (let () body ...)))))
      => (loop ((:for future (in-list futures))
                (:acc futures2 (listing-reverse (touch future))))
               => futures2)
      (parallel-list-loop)))))