;; goof-impl.scm - portable parts of goof 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.


(define-aux-syntaxes
  ;; Auxiliary syntax for the loop clauses
  :when :unless :break :final :bind :subloop :for :acc
  ;; Auxiliary syntax for the iterators.
  :gen
  ;; auxiliary auxiliary syntax
  ;; for vectoring
  :length :fill
  ;;for up-from and down-to
  :to :by
  ;; Internal syntax. %acc is turned into :acc by the forify macro
  ;; it is used make it possible to report an error if :acc is used in
  ;; one of the simple macros.
  %acc
  ;; nop. Used by CL
  :nop)



(include "goof/iterators.scm")


(define-syntax loop
  (syntax-rules ()
    ((loop . rest)
     (%loop (loop . rest) . rest))))

(define-syntax %loop
  (syntax-rules (=>)
    ((%loop o () => expr body ...)
     (%loop o ((:for ensure-once (up-from 0 1))) => expr body ...))
    ((%loop o () body ...)
     (%loop o ((:for ensure-once (up-from 0 1))) body ...))
    ((%loop o name () => expr body ...)
     (%loop o name ((:for ensure-once (up-from 0 1))) => expr body ...))
    ((%loop o  name () body ...)
     (%loop o name ((:for ensure-once (up-from 0 1))) body ...))
    ((%loop o (clauses ...)  body ...)
     (ensure-for-clause #f () (clauses ...) o
                        loop-name
                        body ... (loop-name)))
    ((%loop o name (clauses ...) . body)
     (ensure-for-clause #f () (clauses ...) o name
                        . body))))

;; This ensures that the first subloop has at least ONE for clause. If none is found
;; we add a dummy one!
(define-syntax ensure-for-clause
  (syntax-rules (:for :acc :break :subloop :when :unless :final  DONE)
    ((_ DONE clauses () orig name  . body)
     (cl orig name
         (()) (()) (()) (()) (()) () ((() ())) (())
         clauses . body))
    
    ;; Ensure that a subloop gets run at least once
    ((_ #f (clauses ...) () . rest)
     (ensure-for-clause DONE ((:for dummy (up-from 0 1)) clauses ...) () . rest))
    ((_ #f (done ...) (:subloop . clauses) . rest)
     (ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) :subloop . clauses) () . rest))
    ((_ #f (done ...) ((:when test) . clauses) . rest)
     (ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:when test) . clauses) () . rest))
    ((_ #f (done ...) ((:unless test) . clauses) . rest)
     (ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:unless test) . clauses) () . rest))
    ((_ #f (done ...) ((:break test) . clauses) . rest)
     (ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:break test) . clauses) () . rest))
    ((_ #f (done ...) ((:final test) . clauses) . rest)
     (ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:final test) . clauses) () . rest))
    ((_ _ (done ...) ((:for . stuff) . clauses) . rest)
     (ensure-for-clause DONE (done ... (:for . stuff) . clauses ) () . rest))

    ;; for the rest the clause type does not matter
    ((_ ? (done ...) (clause . clauses) . rest)
     (ensure-for-clause ? (done ... clause) clauses . rest))))
     

(define-syntax push-new-subloop
  (syntax-rules ()
    ((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest)
        (user ...) clauses . body)
     (cl orig name
         (() lets ...)
         (() accs ...)
         (() vars ...)
         (() checks ...)
         (() refs ...)
         f
         ;; propagate :for-finalizers to subloop to be run in case of :break
         ((() (ff-cur ... ff-above ...)) ((ff-cur ...) (ff-above ...)) .  ff-rest)
         (() user ...)
         clauses . body))))


;; cl sorts all the clauses into subloops and positions everything where it should be.
(define-syntax cl
  (syntax-rules (=> :for :acc :when :unless :break :final :bind :subloop)
    ((_ orig name l a v c r f ff user () => expr . body)
     (emit orig name l a v c r f ff user expr . body))
    ((_ orig name l a v c r f ff user () . body)
     (emit orig name l a v c r f ff user (if #f #f) . body))

    ;; user bindings
    ((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) ((:bind (id id* ... expr) ...) clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-ul ... (:bind (id id* ... expr) ...)) . ul-rest) (clauses ...) . body))

    ;; user-whens
    ((_ orig name l a v c r f ff  ((cur-uw ...) . uw-rest) ((:when test) clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-uw ... (:when test)) . uw-rest) (clauses ...) . body))
    ((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) ((:unless test) clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-uw ... (:when (not test))) . uw-rest) (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 ff ((cur-ub ...) . ub-rest)  ((:break expr) clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-ub ... (:break expr)) . ub-rest) (clauses ...) . body))
    ;; user final
    ;; 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 ff ((cur-uw ...) . uw-rest)((:final expr) clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-uw ... (:final expr)) . uw-rest) (clauses ...) . body))
    
    ;; Explicit subloop. Shorthand for (:when #t)
    ((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) (:subloop clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-uw ... :nop) . uw-rest) (clauses ...) . 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 ff ((uw uw* ...) . uw-rest) ((:for for-rest ...) clauses ...) . body)
     (push-new-subloop orig name l a v c r f ff ((uw uw* ...) . uw-rest) ((:for for-rest ...) clauses ...) . body))

    ;; For clause with a sequence creator.
    ((_ orig name l a v c r f ff user((:for id ids ... (iterator source ...)) clauses ...) . body)
     (valid-clause? iterator :for ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff user (clauses ...) . body))

    ;; accumulator clause
    ((_ orig name l a v c r f ff user ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
     (valid-clause? accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff user (clauses ...) . body))

    ;; ERROR HANDLING?
    ((_ orig name l a v c r f ff user (clause . rest) . body)
     (syntax-error "Invalid clause in loop" clause orig))

    ))


;; HOLY CODE-DUPLICATION-BATMAN!
;; cl-next/acc integrates all the bindings by an :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/acc
  (syntax-rules (:acc)
    ;; :acc clause without any subloops
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        ((lets ...))
        ((accs ...))
        vars
        checks
        ((refs ...))
        (finals ...)
        ff ul uw ((cur-ub ...) . ub-rest) uf clauses . body)
     (cl orig name
         ((lets ... new-lets ...))
         ((accs ... (accvar accinit accupdate) ...))
         vars
         checks
         ((refs ... new-refs ...))
         (finals ... new-finals ...)
         ff ul uw ((cur-ub ... new-checks ...) . ub-rest) uf clauses . body))
    ;; We have ONE subloop!
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        (lets ... (outermost-lets ...))
        ((accs ...) ((oldacc oldinit oldupdate) ...))
        vars
        checks
        ((refs ...) . refs-rest)
        (finals ...)
        ff ul uw ((cur-ub ...) . ub-rest) uf clauses . body)
     (cl orig name
         (lets ... (outermost-lets ... new-lets ...))
         ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
         vars
         checks
         ((refs ... new-refs ...) . refs-rest)
         (finals ... new-finals ...)
         ff ul uw ((cur-ub ... new-checks ...) . ub-rest) uf clauses . body))
    ;; We have several subloops!
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        (lets ... (outermost-lets ...))
        ((accs ...) ((oldacc oldinit oldupdate) ...) ... ((oldestacc oldestinit oldestupdate) ...))
        vars
        checks
        ((refs ...) . refs-rest)
        (finals ...)
        ff ul uw ((cur-ub ...) . ub-rest) uf clauses . body)
     (cl orig name
         (lets ... (outermost-lets ... new-lets ...))
         ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
          ((oldestacc oldestinit oldestupdate) ... (accvar accinit accvar) ...))
         vars
         checks
         ((refs ... new-refs ...) . refs-rest)
         (finals ... new-finals ...)
         ff ul uw ((cur-ub ... new-checks ...) . ub-rest) uf clauses . body))))

;; Integrating for clauses is not as involved, since they only want to be introduced into the current
;; loop. Any propagation of for finalizers (ff) is done by push-new-subloop
(define-syntax cl-next/for
  (syntax-rules ()
    ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-for-finals ...)
        orig name
        ((lets ...) . lets-rest)
        accs
        ((vars ...) . vars-rest)
        ((checks ...) . checks-rest)
        ((refs ...) . refs-rest)
        finals
        (((ff-cur ...) (ff-above ...)) . ff-rest)
        user clauses . body)
     (cl orig name
         ((lets ... new-lets ...) . lets-rest)
         accs
         ((vars ... new-vars ...) . vars-rest)
         ((checks ... new-checks ...) . checks-rest)
         ((refs ... new-refs ...) . refs-rest)
         finals
         (((ff-cur ... new-for-finals ...) (ff-above ...)) . ff-rest)
         user clauses . body))
    ((cl err ...)
     (cl err ...))))


(define-syntax user
  (syntax-rules (:when :bind :break :final :nop)
    ((_ final-expr next outer () body ...)
     (begin body ...))

    ((_ f n o (:nop . rest) . body)
     (user f n o rest . body))

    ((_ f n o ((:bind pairs ...) . rest) . body)
     (let (pairs ...)
       (user f n o rest . body)))
    ((_ f n o ((:when test) . rest) . body)
     (cond
      (test (user f n o rest . body))
      (else n)))
    ((_ (final-expr ...) n o ((:break expr) . rest) . body)
     (cond
      (expr final-expr ...)
      (else (user (final-expr ...) n o rest . body))))

    ))

;; If there are 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) ...)
        (((ff-cur ...) (ff-above ...)))
        ((us ...))
        final-expr . body)
     (let* ((final-fun (lambda (final-binding ...) final-expr))
            lets ...)
       (let loop ((accvar accinit) ... (var init) ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               (final-fun final-value ...))
             (ref-let (refs ...)
                      (user (ff-above ... ff-cur ... (final-fun final-value ...))
                            (loop accvar ... step ...)
                            #f
                            (us ...)
                            (let-kw-form name
                                         (final-fun final-value ...)
                                         ()
                                         (loop (accvar accstep) ... (var step) ...)
                                         (let () (if #f #f) . body))))))))))

;; 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) ...)
        (ff-next ... ((ff-cur ...) ()))
        (us-next ... (us ...))
        final-expr
        . body)
     (let* ((final-fun (lambda (final-binding ...) final-expr))
            lets ...)
       (let outer-loop ((accvar accinit) ...
                        (var init) ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               (final-fun final-value ...))
             (ref-let (refs ...)
                      (user (ff-cur ... (final-fun final-value ...))
                            (outer-loop accvar ...  step ...)
                            #f
                            (us ...)
                            (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 ...)
                                            (ff-next ...)
                                            (us-next ...)
                                            . body)))))))))

(define-syntax emit-many/rest
  (syntax-rules ()
    ;; match innermost loop
    ((_ orig
        name
        outer
        ((lets ...))
        (((accvar accinit accstep) ...))
        (((var init step) ...))
        ((checks ...))
        ((refs ...))
        final
        (((ff-cur ...) (ff-above ...)))
        ((us ...))
        . body)
     (let* (lets ...)
       (let innermost-loop ((accvar accinit) ...
                            (var init) ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               outer)
             (ref-let (refs ...)
                      (user (ff-cur ... ff-above ... final)
                            (innermost-loop accstep ... step ...)
                            #f
                            (us ...)
                            (let-kw-form name final () (innermost-loop (accvar accstep) ... (var step) ...)
                                         . body)))))))

    ;; 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
        (next-ff ... ((ff-cur ...) (ff-above ...)))
        (us-next ... (us ...))
        . body)
     (let* (lets ...)
       (let intermediate-loop ((accvar accinit) ...
                               (var init) ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               outer)
             (ref-let (refs ...)
                      (user (ff-cur ... ff-above ... final)
                            (intermediate-loop accstep ... step ...)
                            #f
                            (emit-many/rest orig
                                            name
                                            (intermediate-loop accstep ... step ...)
                                            (next-lets ...)
                                            (next-accs ...)
                                            (next-vars ...)
                                            (next-checks ...)
                                            (next-refs ...)
                                            final
                                            (next-ff ...)
                                            (us-next ...)
                                            . body)))))))))

(define-syntax forify
(syntax-rules (%acc)
  ((_ orig name () ((%acc . acc-rest) . argsrest) . body)
   (forify* orig name () ((:for ensure-once (up-from 0 1)) (%acc . acc-rest) . argsrest) . body))
  ((_ . rest)
   (forify* . rest))))

(define-syntax forify*
  (syntax-rules (:for :acc :when :unless :break :final :subloop :let :let* %acc)
    ((_ o n done-clauses () . body)
     (%loop o n done-clauses . body))
    ((_      o n (s ...) ((:for c-rest ...) clauses ...) . body)
     (forify* o n (s ... (:for c-rest ...)) (clauses ...) . body))
    ((_      o n (s ...) ((:when expr) clauses ...) . body)
     (forify* o n (s ... (:when expr)) (clauses ...) . body))
    ((_      o n (s ...) ((:unless expr) clauses ...) . body)
     (forify* o n (s ... (:unless expr)) (clauses ...) . body))
    ((_      o n (s ...) ((:break expr) clauses ...) . body)
     (forify* o n (s ... (:break expr)) (clauses ...) . body))
    ((_      o n (s ...) ((:final expr) clauses ...) . body)
     (forify* o n (s ... (:final expr)) (clauses ...) . body))
    ((_      o n (s ...) (:subloop clauses ...) . body)
     (forify* o n (s ... :subloop) (clauses ...) . body))
    ((_      o n (s ...) ((:let id id* ... expr) clauses ...) . body)
     (forify* o n (s ... (:let id id* ... expr)) (clauses ...) . body))
    ((_      o n (s ...) ((:let* id id* ... expr) clauses ...) . body)
     (forify* o n (s ... (:let* id id* ... expr)) (clauses ...) . body))
    ((_      o n (s ...) ((%acc c-rest ...) clauses ...) . body)
     (forify* o n (s ... (:acc c-rest ...)) (clauses ...) . body))
    ((_      o n (s ...) ((:acc c-rest ...) clauses ...) . body)
     (syntax-error "Accumulating clauses are not allowed in simplified loop forms." o))
    ((_      o n (s ...) ((id id* ... (iterator source ...)) clauses ...) . body)
     (forify* o n (s ... (:for id id* ... (iterator source ...))) (clauses ...) . body))))

(define-syntax loop/list
  (syntax-rules ()
    ((_  (clauses ...) body ...)
     (forify (loop/list (clauses ...) body ...)
             loop-name () (clauses ...)
       => '()
       (cons (let () body ...) (loop-name))))))

(define-syntax loop/sum
  (syntax-rules ()
    ((_ (clauses ...) body ...)
     (forify (loop-sum (clauses ...) body ...)
             loop-name
             () (clauses ... (%acc acc (summing (let () body ...))))
       => acc
       (loop-name)))))

(define-syntax loop/product
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             product-loop () (clauses ... (%acc acc (multiplying (let () body ...))))
             => acc
             (product-loop)))))

(define sentinel (list 'unique))

;; TODO: maybe have a look at the expansion of this. It seems weird.
(define-syntax loop/first
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             loop/first
             () (clauses ... (:final #t))
             => #f
             body ...))))


(define-syntax loop/last
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             loop-name () (clauses ... (%acc acc (folding sentinel)))
             => (if (eq? sentinel acc) #f acc)
             (let ((result (let () body ...)))
               (loop-name (=> acc result)))))))

(define-syntax loop/and
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             and-loop
             () (clauses ... (%acc acc (folding #t)))
       => acc
       (let ((res (let () body ...)))
         (and res (and-loop (=> acc res))))))))

(define-syntax loop/or
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             or-loop
             () (clauses ...)
       => #f
       (or (let () body ...) (or-loop))))))