goof-loop/goof.scm

;; goof loop - a bastardisation of chibi loop.
;;
;; Copyright 2020 Linus Björnstam
;; Copyright 2000-2015 Alex Shinn (original author of chibi-loop)
;; All rights reserved.
;;
;; 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.
;;
;; It extends chibi loop in the following way:
;;   * adds support for binding variables in the loop clauses.
;;   * Adds :when, :unless, and :break clauses that controls when the loop
;;     body executes and when values are collected by accumulating for clauses.
;;     similar to how #:when, #:unless and #:break works in racket.
;;
;;   It restricts chibi loops in the following ways:
;;    * with- and for-clauses  are no longer visible in the final expression, for that you
;;      must use an accumulator clause.
;;    * Positional update is not supported. It seems error-prone once you start
;;      having a lot of loop variables, and because goof-loop does some re-ordering
;;      that foof loop does not. For example:
;;        (:for a (in 0 (+ a 1))) (:acc acc (in '() (cons a acc)))
;;      are actually reordered in a loop, because accumulators and for loops are separated
;;      due to having to propagate the accumulators through the loop.


(use-modules (helpers)
             (srfi srfi-71))

(include "iterators.scm")

(define-aux-syntaxes :for :when :unless :break :final :let :let* :acc :subloop)

(define-syntax loop
  (syntax-rules ()
    ((loop (clauses ...)  body ...)
     (cl (loop (clauses ...) body ...)
         loop-name
         (()) (()) (()) (()) (()) () (()) (()) (())
         (clauses ...)
         body ... (loop-name)))
    ((loop name (clauses ...) . body)
     (cl (loop name (clauses ...) . body)
         name
         (()) (()) (()) (()) (()) () (()) (()) (())
         (clauses ...)
         . body))))

(define-syntax push-new-subloop
  (syntax-rules ()
    ((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (ul ...) (uw ...) (ub ...) clauses . body)
     (cl orig name
         (() lets ...)
         (() accs ...)
         (() vars ...)
         (() checks ...)
         (() refs ...)
         f
         (() ul ...)
         (() uw ...)
         (() ub ...)
         clauses . body))))


;; Clauses sorts all the clauses into subloops and positions everything where it should be.
(define-syntax cl
  (syntax-rules (=> in :for :with :when :unless :break :final :let :acc)
    ((_ orig name l a v c r f ul uw ub () => expr . body)
     (emit orig name l a v c r f ul uw ub expr . body))
    ((_ orig name l a v c r f ul uw ub () . body)
     (emit orig name l a v c r f ul uw ub (if #f #f) . body))
    ;; :for-clauses
    ;; found a for clause when we have a :when or :unless clause. Push new subloop
    ((_ orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((:for for-rest ...) clauses ...) . body)
     (push-new-subloop orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((:for for-rest ...) clauses ...) . body))

    ;; The four special :for var (in ...)-clauses where user specifies their own iteration
    ((_ orig name l a v c r f ul ((uw uw* ...) uw-rest ...) ub ((:with args ...) clauses ...) . body)
     (push-new-subloop name l a v c r f ul ((uw uw* ...) uw-rest ...) ub ((:with args ...) clauses ...) . body))
    
    ((_ orig name l a ((v-cur ...) . v-rest)  ((c-cur ...) . c-rest)
        r f ul uw ub ((:for var (in init step guard-expr)) clauses ...) . body)
     (cl orig name l a ((v-cur ... (var init step)) . v-rest) ((c-cur ... guard-expr) . c-rest)
         r f ul uw ub (clauses ...) . body))
    ((_ orig name l a ((v-cur ...) . v-rest) c r f ul uw ub ((:for var (in init step)) clauses ...) . body)
     (cl orig name l a ((v-cur ... (var init step)) . v-rest) c r f ul uw ub (clauses ...) . body))
    ((_ orig name l a ((v-cur ...) . v-rest) c r f ul uw ub ((:for var (in init)) clauses ...) . body)
     (cl orig name l a ((v-cur ... (var init var)) . v-rest) c r f ul uw ub (clauses ...) . body))
    ;; For clause with a sequence creator.
    ((_ orig name l a v c r f ul uw ub ((:for id ids ... (iterator source ...)) clauses ...) . body)
     (iterator ((id ids ...) (source ...)) cl-next orig name l a v c r f ul uw ub (clauses ...) . body))

    ;; Accumulating clauses
    ;; should I push a subloop on a when clause?
    ;; Currently these have no stop or if-clauses. Maybe add?
    ((_ orig name l a v c r f ul uw ub ((:acc var (in init update)) clauses ...) . body)
     (cl-next () ((var init update)) () () () ((var var)) orig name l a v c r f ul uw ub (clauses ...) . body))
    ((_ orig name l a v c r f ul uw ub ((:acc var (in init)) clauses ...) . body)
     (cl-next () ((var init var)) () () () ((var var)) orig name l a v c r f ul uw ub (clauses ...) . body))
    ;; Accumulator clause with a proper accumulator.
    ((_ orig name l a v c r f ul uw ub ((:acc id ids ... (iterator source ...)) clauses ...) . body)
     (iterator ((id ids ...) (source ...)) cl-next orig name l a v c r f ul uw ub (clauses ...) . body))

    ;; user-whens
    ((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub ((:when test) clauses ...) . body)
     (cl orig name l a v c r f ul ((cur-uw ... test) . uw-rest) ub (clauses ...) . body))
    ((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub ((:unless test) clauses ...) . body)
     (cl orig name l a v c r f ul ((cur-uw ... (not test)) . uw-rest) ub (clauses ...) . body))
    ;; USER BREAKS
    ;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards.
    ((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) ((:break expr) clauses ...) . body)
     (cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) (clauses ...) . body))
    ;; USER LETS
    ((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub ((:let id id* ... expr) clauses ...) . body)
     (cl orig name l a v c r f ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub (clauses ...) . body))
    ((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub ((:let* id id* ... expr) clauses ...) . body)
     (cl orig name l a v c r f ((cur-ul ... (:let* id id* ... expr)) . ul-rest) (clauses ...) . body))

    ;; Explicit subloop. Shorthand for (:when #t)
    ((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:subloop clauses ...) . body)
     (cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ub (clauses ...) . body))
    
    ;; ERROR HANDLING?
    ((_ orig name l a v c r f ul uw ub (clause . rest) . body)
     (syntax-error "Invalid clause in loop" clause orig))

    ))


;; HOLY CODE-DUPLICATION-BATMAN!
;; cl-next integrates any bindings introduced by a :for or :acc clause. The complexity comes from pushing :acc-clauses
;; into the outer loops. Since accumulators need to be available in the (final-fun ...), they need to be visible also
;; in the outer loops if the loop exits there.
(define-syntax cl-next
  (syntax-rules ()
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        ((lets ...))
        ((accs ...))
        ((vars ...))
        ((checks ...))
        ((refs ...))
        (finals ...) ul uw ub clauses . body)
      (cl orig name
          ((lets ... new-lets ...))
          ((accs ... (accvar accinit accupdate) ...))
          ((vars ... new-vars ...))
          ((checks ... new-checks ...))
          ((refs ... new-refs ...))
          (finals ... new-finals ...)
          ul uw ub clauses . body))
    ;; We have ONE subloop!
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        ((lets ...) . lets-rest)
        ((accs ...) ((oldacc oldinit oldupdate) ...))
        ((vars ...) . vars-rest)
        ((checks ...) . checks-rest)
        ((refs ...) . refs-rest)
        (finals ...) ul uw ub clauses . body)
      (cl orig name
          ((lets ... new-lets ...) . lets-rest)
          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
          ((vars ... new-vars ...) . vars-rest)
          ((checks ... new-checks ...) . checks-rest)
          ((refs ... new-refs ...) . refs-rest)
          (finals ... new-finals ...)
          ul uw ub clauses . body))
    ;; We have several subloops!
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        ((lets ...) . lets-rest)
        ((accs ...) ((oldacc oldinit oldupdate) ...) ... ((oldestacc oldestinit oldestupdate) ...))
        ((vars ...) . vars-rest)
        ((checks ...) . checks-rest)
        ((refs ...) . refs-rest)
        (finals ...) ul uw ub clauses . body)
      (cl orig name
          ((lets ... new-lets ...) . lets-rest)
          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
           ((oldestacc oldestinit oldestupdate) ... (accvar accinit accvar) ...))
          ((vars ... new-vars ...) . vars-rest)
          ((checks ... new-checks ...) . checks-rest)
          ((refs ... new-refs ...) . refs-rest)
          (finals ... new-finals ...)
          ul uw ub clauses . body))))
        


(define-syntax user-let
  (syntax-rules (:let :let*)
    ((_ () () () body ...)
     (begin body ...))
    ((_ (lets ...) () () . body)
     (let (lets ...)
       . body))
    ((_ () (stars ...) () . body)
     (let* (stars ...) . body))

    ;; These twe clauses handle let type changes.
    ((_ () (stars ... last) ((:let id id* ... expr) clauses ...) . body)
     (let* (stars ...)
       (user-let (last (id id* ... expr)) () (clauses ...) . body)))
    ((_ (lets ...) () ((:let* id id* ... expr) clauses ...) . body)
     (let (lets ...)
       (user-let () ((id id* ... expr)) (clauses ...) . body)))

    ;; 2 clauses new of the same that already existed
    ((_ (lets ...) () ((:let id id* ... expr) clauses ...) . body)
     (user-let (lets ... (id id* ... expr)) () (clauses ...) . body))
    ((_ () (stars ...) ((:let* id id* ... expr) clauses ...) . body)
     (user-let () (stars ... (id id* ... expr)) (clauses ...) . body))))

;; If there is no subloops, we emit to the simple case
(define-syntax emit
  (syntax-rules ()
    ((_ orig name (one) . rest)
     (emit-one orig name (one) . rest))
    ((_ orig name . rest)
     (emit-many/first #f name . rest))))
    
(define-syntax emit-one
  (syntax-rules ()
    ((_ orig name
        ((lets ...))
        (((accvar accinit accstep) ...))
        (((var init step) ...))
        ((checks ...))
        ((refs ...))
        ((final-binding final-value) ...)
        ((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) final-expr . body)
     (let* (lets ...)
       (define (final-fun final-binding ...)
         final-expr)
       (define (loopy-loop accvar ... var ...)
         (if (or checks ...)
             (final-fun final-value ...)
             (let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)
                     (let-kw-form name (loopy-loop (accvar accstep) ... (var step) ...)
                       (if (or user-breaks ...)
                           (final-fun final-value ...)
                           (let () (if #f #f) . body)))
                     (loopy-loop accvar ... step ...))))))
       (loopy-loop accinit ... init ...)))))

;; Emit-many/first emits the outermost let loop and binds the final lambda.
(define-syntax emit-many/first
  (syntax-rules ()
    ((_ orig name
        (lets-next ... (lets ...))
        (accs-next ... ((accvar accinit accstep) ...))
        (vars-next ... ((var init step) ...))
        (checks-next ... (checks ...))
        (refs-next ... (refs ...))
        ((final-binding final-value) ...)
        (ul-next ... (user-lets ...))
        (uw-next ... (user-whens ...))
        (ub-next ... (user-breaks ...))
        final-expr
        . body)
     (let* ((final-fun (lambda (final-binding ...) final-expr))
            lets ...)
       (let outer-loop ((accvar accinit) ...
                        (var init) ...)
         (if (or checks ...)
             (final-fun final-value ...)
             (let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)
                     (cond
                      ((or user-breaks ...)  (final-fun final-value ...))
                      (else (emit-many/rest orig
                                             name
                                             (outer-loop accstep ... step ...)
                                             (lets-next ...)
                                             (accs-next ...)
                                             (vars-next ...)
                                             (checks-next ...)
                                             (refs-next ...)
                                             ;; THIS IS NOW A COMPLETE call to final
                                             (final-fun final-value ...)
                                             (ul-next ...)
                                             (uw-next ...)
                                             (ub-next ...)
                                             . body)))
                     (outer-loop accvar ... step ...))))))))))

(define-syntax emit-many/rest
  (syntax-rules ()
    ;; match innermost loop
    ((_ orig
        name
        outer
        ((lets ...))
        (((accvar accinit accstep) ...))
        (((var init step) ...))
        ((checks ...))
        ((refs ...))
        final
        ((user-lets ...))
        ((user-whens ...))
        ((user-breaks ...))
        . body)
     (let* (lets ...)
       (let innermost-loop ((accvar accinit) ...
                            (var init) ...)
         (if (or checks ...)
             outer
             (let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)         
                     (cond
                      ((or user-breaks ...) final)
                      (else
                       (let-kw-form name (innermost-loop (accvar accstep) ... (var step) ...)
                         . body)))
                     (innermost-loop accvar ... step ...))))))))

    ;; Any intermediate loops
    ((_ orig
        name
        outer
        (next-lets ... (lets ...))
        (next-accs ... ((accvar accinit accstep) ...))
        (next-vars ... ((var init step) ...))
        (next-checks ... (checks ...))
        (next-refs ... (refs ...))
        final
        (ul-next ... (user-lets ...))
        (uw-next ... (user-whens ...))
        (ub-next ... (user-breaks ...))
        . body)
     (let* (lets ...)
       (let intermediate-loop ((accvar accinit) ...
                               (var init) ...)
         (if (or checks ...)
             outer
             (let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)
                     (if (or user-breaks ...)
                         final
                         (emit-many/rest
                          orig
                          name
                          (intermediate-loop accstep ... step ...)
                          (next-lets ...)
                          (next-accs ...)
                          (next-vars ...)
                          (next-checks ...)
                          (next-refs ...)
                          final
                          (ul-next ...)
                          (uw-next ...)
                          (ub-next ...)
                          . body))
                     (intermediate-loop accvar ... step ...))))))))))
             


;; 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 parameter 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->list stx)
  (syntax-case stx ()
    ((a ...) #'(a ...))))

(define-syntax let-kw-form
  (syntax-rules ()
    ((_ macro-name (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))
                               #'(loop-name 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
  (syntax-rules ()
    ((_  (clauses ...) body ...)
     (loop loop-name (clauses ...)
       => '()
       (cons (let () body ...) (loop-name))))))