;;; CHICKEN Transducers - Transducers for working with foldable data types.
;;;
;;; Copyright (c) 2023 Jeremy Steward
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in all
;;; copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(define-library (transducers mappings)
  (import (scheme base)
          (scheme case-lambda)
          (srfi 128)
          (rename (srfi 146)
                  (mapping-fold srfi-146#mapping-fold)
                  (mapping-fold/reverse srfi-146#mapping-fold/reverse))
          (rename (srfi 146 hash)
                  (hashmap-fold srfi-146#hashmap-fold))
          (transducers base))

  (cond-expand
    (chicken-5
      (import (only (check-errors) define-check+error-type)))
    (else
      (error "Transducers does not yet support this R7RS Scheme implementation.")))

  (include-library-declarations "src/transducers.mappings.exports.scm")

  (begin
    ;; A reducer that aggregates the transduction into a new mapping in the
    ;; order of items reduced.
    ;;
    ;; Relies on every `item` being a pair.
    (define collect-mapping
      (case-lambda
        (() (collect-mapping (make-default-comparator)))
        ((sentinel)
         (case-lambda
           (() (mapping sentinel))
           ((result) result)
           ((result item)
            (let ((key (car item))
                  (value (cdr item)))
              (mapping-set result key value)))))))

    ;; A reducer that aggregates the transduction into a new hashmap in the
    ;; order of items reduced.
    ;;
    ;; Relies on every `item` being a pair.
    (define collect-hashmap
      (case-lambda
        (() (collect-hashmap (make-default-comparator)))
        ((sentinel)
         (case-lambda
           (() (hashmap sentinel))
           ((result) result)
           ((result item)
            (let ((key (car item))
                  (value (cdr item)))
              (hashmap-set result key value)))))))

    ;; Transducer-aware folding operation on mappings.
    ;;
    ;; This procedure takes in a reducer `f`, a `sentinel` value for that
    ;; reducer, and a mapping `xs` to call `(f sentinel x)` on repeatedly,
    ;; taking the result of the reducer as the new sentinel value each time.
    (define (mapping-fold f sentinel xs)
      (call/cc (lambda (cc)
                 (srfi-146#mapping-fold
                   (lambda (key value s)
                     (let ((result (f s (cons key value))))
                       (if (reduced? result)
                         (cc (unwrap result))
                         result)))
                   sentinel
                   xs))))

    ;; Transducer-aware folding operation on mappings.
    ;;
    ;; Operates in the reverse order of the items compared to mapping-fold.
    (define (reverse-mapping-fold f sentinel xs)
      (call/cc (lambda (cc)
                 (srfi-146#mapping-fold/reverse
                   (lambda (key value s)
                     (let ((result (f s (cons key value))))
                       (if (reduced? result)
                         (cc (unwrap result))
                         result)))
                   sentinel
                   xs))))

    ;; Transducer-aware folding operation on hashmaps.
    ;;
    ;; This procedure takes in a reducer `f`, a `sentinel` value for that
    ;; reducer, and a hashmap `xs` to call `(f sentinel x)` on repeatedly,
    ;; taking the result of the reducer as the new sentinel value each time.
    (define (hashmap-fold f sentinel xs)
      (call/cc (lambda (cc)
                 (srfi-146#hashmap-fold
                   (lambda (key value s)
                     (let ((result (f s (cons key value))))
                       (if (reduced? result)
                         (cc (unwrap result))
                         result)))
                   sentinel
                   xs))))

    ;; A transducer that flattens a mapping onto a transduction.
    (define-flatten-transducer flatten-mapping mapping? mapping-fold)

    ;; A transducer that flattens a mapping onto a transduction in reverse
    ;; order.
    (define-flatten-transducer flatten-reverse-mapping mapping? reverse-mapping-fold)

    ;; A transducer that flattens a hashmap onto a transduction.
    (define-flatten-transducer flatten-hashmap hashmap? hashmap-fold)

    ;; A transducer that chains a mapping onto a transduction.
    (define-chain-transducer chain-mapping mapping-fold)

    ;; A transducer that chains a mapping in reverse order onto a transduction.
    (define-chain-transducer chain-reverse-mapping reverse-mapping-fold)

    ;; A transducer that chains a hashmap onto a transduction.
    (define-chain-transducer chain-hashmap hashmap-fold)

    ;; A transducer that interleaves a mapping onto a transduction.
    (define (interleave-mapping m)
      (lambda (reducer)
        (let ((state m))
          (case-lambda
            (() (reducer))
            ((result) (reducer result))
            ((result item)
             (if (mapping-empty? state)
               (make-reduced result)
               (let-values (((new-state key value) (mapping-pop state)))
                 (let ((next-result (reducer result item)))
                   (set! state new-state)
                   (if (reduced? next-result)
                     next-result
                     (reducer next-result (cons key value)))))))))))

    ;; A transducer that interleaves a hashmap onto a transduction.
    (define (interleave-hashmap hm)
      (lambda (reducer)
        (let ((state hm))
          (case-lambda
            (() (reducer))
            ((result) (reducer result))
            ((result item)
             (if (hashmap-empty? state)
               (make-reduced result)
               (let-values (((new-state key value) (hashmap-pop state)))
                 (let ((next-result (reducer result item)))
                   (set! state new-state)
                   (if (reduced? next-result)
                     next-result
                     (reducer next-result (cons key value)))))))))))

    ;; A transducer that zips a mapping onto a transduction.
    (define (zip-mapping m)
      (lambda (reducer)
        (let ((state m))
          (case-lambda
            (() (reducer))
            ((result) (reducer result))
            ((result item)
             (if (mapping-empty? state)
               (make-reduced result)
               (let-values (((new-state key value) (mapping-pop state)))
                 (set! state new-state)
                 (reducer result (cons item (cons key value))))))))))

    ;; A transducer that zips a hashmap onto a transduction.
    (define (zip-hashmap hm)
      (lambda (reducer)
        (let ((state hm))
          (case-lambda
            (() (reducer))
            ((result) (reducer result))
            ((result item)
             (if (hashmap-empty? state)
               (make-reduced result)
               (let-values (((new-state key value) (hashmap-pop state)))
                 (set! state new-state)
                 (reducer result (cons item (cons key value))))))))))

    ;; A transducible type-class over mappings.
    (define mapping-transducible
      (make-transducible mapping-fold
                         collect-mapping
                         flatten-mapping
                         chain-mapping
                         interleave-mapping
                         zip-mapping))

    ;; A transducible type-class over hashmaps.
    (define hashmap-transducible
      (make-transducible hashmap-fold
                         collect-hashmap
                         flatten-hashmap
                         chain-hashmap
                         interleave-hashmap
                         zip-hashmap)))

  ;; End-of-module
  )