(use magic-pipes)
(use args)
(use ports)
(use chicken-syntax)
(use alist-lib)

(define opts
  (list
   (args:make-option (n context) (required: "INTEGER")
                     "Number of sexprs of previous context to provide [default: 0]")
   (args:make-option (a default-context) (required: "EXPR")
                     "Default previous context for before the start of input")
   (args:make-option (t pass-as-list) #:none
                     "Pass current and context sexprs as a list to the fold-procedure, rather than as separate arguments")
   (args:make-option (o output) (required: "PROCEDURE-EXPR")
                     "Pass the output sexpr through a post-processing procedure of one argument")))

(define-record-type fold-state
  (make-fold-state user-acc history)
  fold-state?
  (user-acc fold-state-user-acc)
  (history fold-state-history))

(define (update-history previous-history new-value context)
  (let ((h (cons new-value previous-history)))
    (if (> (length h) context)
        (take h context)
        h)))

(define (prepare-history history
                         default-context
                         context)
  (cond
   ((< (length history) context)
    (append history
            (make-list (- context (length history))
                       default-context)))
   ((= (length history) context)
    history)))

(receive (options operands before-exprs after-exprs usage)
         (parse-mp-args (command-line-arguments)
                        opts
                        "fold-procedure-expr <initial-value-expr>"
                        "Read s-expressions from standard input, applies the
fold-procedure to them and to the result of the previous call,
starting with the supplied initial-value, or #f if none is
specified, and then writes the final value to standard output.")
         (unless (or (= (length operands) 1)
                     (= (length operands) 2))
                 (usage))
         (let* ((fold-expr (parse-code (car operands)))
                (init-value(if (= (length operands) 2)
                               (parse-code (cadr operands))
                               (void)))
                (context (string->number
                          (alist-ref options 'context (lambda () "0"))))
                (use-default-context #t)
                (default-context (parse-code
                                  (alist-ref options 'default-context
                                             (lambda ()
                                               (set! use-default-context #f)
                                               "#f"))))
                (out-expr (parse-code (alist-ref options 'output (lambda () "#f"))))
                (pass-as-list (assq 'pass-as-list options))
                (ec (make-eval-context before-exprs
                                       (list
                                        fold-expr
                                        out-expr)
                                       after-exprs))
                (fold-proc (eval-context-handler-closure ec 0))
                (out-proc (eval-context-handler-closure ec 1)))
           (let ((result (fold-input-data
                          (lambda (input acc)
                            (let ((new-acc
                                   (without-input-port
                                    (lambda ()
                                      (if pass-as-list
                                          (fold-proc (cons
                                                      input
                                                      (fold-state-history acc))
                                                     (fold-state-user-acc acc))
                                          (if (or use-default-context
                                                  (>= (length (fold-state-history acc))
                                                      context))
                                              (apply fold-proc
                                                     (append (list input)
                                                             (prepare-history
                                                              (fold-state-history acc)
                                                              default-context
                                                              context)
                                                             (list (fold-state-user-acc acc))))
                                              (fold-state-user-acc acc)) ;; Skip fold until we have more history
                                          )))))
                              (make-fold-state new-acc
                                               (update-history
                                                (fold-state-history acc)
                                                input
                                                context))))
                          (make-fold-state init-value '()))))

             (with-values-to-output
              (lambda ()
                (if out-proc
                    (without-input-port
                     (lambda ()
                       (out-proc (fold-state-user-acc result))))
                    (data-write
                     (fold-state-user-acc result))))))
           (without-input-port
            (eval-context-end-closure ec))))