;; 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.
;;   * Planned: add support for subloops, akin to what the starified loops of
;;     racket do.
;;
;;   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 a clause for which I don't have a name yet.


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

(include "iterators.scm")

;; TODO: Add intermediate subloops. Make sure that accumulators are properly propagated.
;; TODO. fix let-kw-form. Don't use mutation. This should work:(define (partition predicate list)
;; (loop continue ((:for element (in-list list))
;;                 (:acc satisfied (in  '()))
;;                 (:acc  unsatisfied  (in '())))
;;   => (values (reverse satisfied)
;;              (reverse unsatisfied))
;;   (if (predicate element)
;;       (continue (=> satisfied (cons element satisfied)))
;;       (continue (=> unsatisfied (cons element unsatisfied))))))



(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))  

    ;; 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))

    ))


;; cl-next integrates the results
;; THIS WILL NEED TO BE UPDATED TO PROPERLY PUSH (accvar accinit accvar) ... down to the first accumulator. currently it
;; will be re-initialized for every previous loop except the innermost one.
;; THIS needs to work:
;; (loop ((:for a (in-list '((1 2) (3 4) (5 6))))
;;        (:when #t)
;;        (:for b (in-list a))
;;        (:for acc (listing b)))
;;   => acc)
;; as well as this:
;; (loop ((:for a (in-list '(((1) (2)) ((3) (4)) ((5) (6 7)))))
;;        (:when #t)
;;        (:for b (in-list a))
;;        (:when :t)  
;;        (:for c (in-list b))
;;        (:for acc (listing c)))
;;   => acc)

(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 a 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))))
        


(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
        next
        ((lets ...))
        (((accvar accinit accstep) ...))
        (((var init step) ...))
        ((checks ...))
        ((refs ...))
        final
        ((user-lets ...))
        ((user-whens ...))
        ((user-breaks ...))
        . body)
     (let innermost-loop ((accvar accinit) ...
                          (var init) ...)
       (let* (lets ...)
         (if (or checks ...)
             next
             (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
        next
        (next-lets ... (lets ...))
        (next-accs ... ((accvar accinit accupdate) ...))
        (next-vars ... ((var init update) ...))
        (next-checks ... (checks ...))
        (next-refs ... (refs ...))
        final
        (ul-next ... (user-lets ...))
        (uw-next ... (user-whens ...))
        (ub-next ... (user-breaks ...))
        . body)
     (display "not implemented"))))


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

(define (named-update? syn)
  (syntax-case syn (=>)
    ((=> var update) #t)
    (_ #f)))


(define (update-psn! params psn val)
  (list-set! params psn
             (list (car (list-ref params psn)) val)))

(define (update-name! params name val)
  (let loop ((params params))
    (cond
     ((null? params) (error "unknown loop parameter name " name (list '=> name val)))
     ((syntax= name (caar params))
      (set-cdr! (car params) (list val))
      (display (syntax->datum val))
      )
     (else
      (loop (cdr params))))))

(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)
                     ;; this way of formulating params means it is an alist with syntax objects
                     ;; as keys instead of a list of syntax objects
                     (define params (list #'(var step) ...))
                     (with-ellipsis :::
                       (let loop ((lst (cdr (syntax->list stx))) (pos 0))
                         (if (null? lst)
                             (with-syntax ((((v s) :::) params))
                               #'(loop-name s :::))
                             (syntax-case (car lst) (=>)
                               ((=> name val)
                                (update-name! params #'name #'val)
                                (loop (cdr lst) #f))
                               (val pos
                                 (begin
                                   (update-psn! params psn #'val)
                                   (loop (cdr lst) (+ pos 1))))
                               (_ (error "Positional arguments cannot be updated after a named argument")))))))))
       . body))))