#| Copyright 2024 Peter McGoron
 |
 | Licensed under the Apache License, Version 2.0 (the "License");
 |
 | you may not use this file except in compliance with the License.
 | You may obtain a copy of the License at
 |
 |     http://www.apache.org/licenses/LICENSE-2.0
 |
 | Unless required by applicable law or agreed to in writing, software
 | distributed under the License is distributed on an "AS IS" BASIS,
 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 | See the License for the specific language governing permissions and
 | limitations under the License.
 |#

(define-syntax cond-values
  (syntax-rules (else)
    ((cond-values clauses ... (else body ...))
     (cond-thunk clauses ... (else body ...)))
    ((cond-values clauses ...)
     (cond-thunk clauses ... (else (values))))))

(define-syntax %after
  (syntax-rules (on-fail! %lambda %body when let =>)
    ((_ old-abort %lambda ((on-fail! on-error) clauses ...) body ...)
     (lambda ()
       (let ((abort (lambda () on-error)))
         (%after abort %body (clauses ...) body ...))))
    ((_ old-abort %body ((on-fail! on-error) clauses ...) body ...)
     (let ((abort (lambda () on-error)))
       (%after abort %body (clauses ...) body ...)))
    ((_ abort action ((when conditional) clauses ...) body ...)
     (if conditional
         (%after abort action (clauses ...) body ...)
         (abort)))
    ((_ abort action ((let value => formal) clauses ...) body ...)
     (case-receive value
       (() (abort))
       (formal (%after abort action (clauses ...) body ...))))
    ((_ abort %lambda () body ...)
     (lambda () body ...))
    ((_ abort %body () body ...)
     (begin body ...))))

(define-syntax after
  (syntax-rules ()
    ((after (clauses ...) body ...)
     (let ((abort (lambda () #f)))
       (%after abort %lambda (clauses ...) body ...)))))

(define-syntax apply-after
  (syntax-rules ()
    ((apply-after producer consumer)
     (after ((let producer => formal))
       (apply consumer formal)))))

(define (pair=> x)
  (cond-values
    (after ((when (pair? x)))
      (values (car x) (cdr x)))))

(define (list-length-destructor whole-list num kont)
  (cond-thunk
    (when-ct (not (integer? num))
      (error "must be integer" num))
    (when-ct (not (positive? num))
      (error "must be positive" num))
    (else
     (let loop ((iterator whole-list)
                (collected '())
                (num num))
       (cond-values
         (after ((when (= num 0)))
           (kont collected iterator))
         (after ((let (pair=> iterator) => (head rest)))
           (loop rest (cons head collected) (- num 1))))))))

(define (length-at-least=> whole-list num)
  (list-length-destructor whole-list num
                          (lambda (reverse-seen rest)
                            (cond-values
                              (when-ct (or (null? rest) (pair? rest))
                                (apply values
                                       (reverse (cons rest reverse-seen))))))))

(define (length=> whole-list num)
  (list-length-destructor whole-list num
                          (lambda (_ rest)
                            (cond-values
                              (when-ct (null? rest)
                                (apply values whole-list))))))

(define-syntax define-record-type/destructor
  (syntax-rules ()
    ((_ type-name cstr predicate? destructor=>
        (arg-name accessor setter ...)
        ...)
     (begin
       (define-record-type type-name
         cstr
         predicate?
         (arg-name accessor setter ...)
         ...)
       (define (destructor=> record)
         (cond-values
           (after ((when (predicate? record)))
             (values (accessor record) ...))))))))