;;
;; util-kwargs.scm
;;
;; Syntax infrastructure for kwargs procedure definitions.
;;
;; ISC License
;;
;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;

(declare (unit util-kwargs))

(module
 util-kwargs
 (
  define-kwproc
  let-kwargs*
  let-kwargs**
  split-kwargs
  )
 (import scheme
	 (chicken base)
	 (chicken keyword))

 ;; Splits arguments into two lists: the kw-args and non-kw-args
 (define (split-kwargs args)
   (let loop ((args args)
	      (kw-args '())
	      (non-kw-args '()))
     (if (null? args)
	 (values kw-args
		 (reverse non-kw-args))
	 (if (keyword? (car args))
	     (if (null? (cdr args))
		 (error 'split-kwargs "missing keyword pair" (car args))
		 (loop (cddr args)
		       (cons (car args)
			     (cons (cadr args)
				   kw-args))
		       non-kw-args))
	     (loop (cdr args)
		   kw-args
		   (cons (car args) non-kw-args))))))

 ;; Parses all the variants of keyword and positional arguments in the
 ;; list.
 (define-syntax let-kwargs**
   (syntax-rules ()
     ;; End, without rest
     ((_ name
	 (kw-args non-kw-args)
	 ()
	 expr ...)
      (if (null? non-kw-args)
	  (let ()
	    expr ...)
	  (error 'name "too many arguments" non-kw-args)))
     ;; Explicit default for kw-arg
     ((_ name
	 (kw-args non-kw-args)
	 ((kw binding) . rest)
	 expr ...)
      (let-kwargs** name
		    (kw-args non-kw-args)
		    ((kw binding #f) . rest)
		    expr ...))
     ;; A kw-args with default
     ((_ name
	 (kw-args non-kw-args)
	 ((kw binding default) . rest)
	 expr ...)
      (let ((binding (get-keyword kw kw-args (lambda () default))))
	(let-kwargs** name
		      (kw-args non-kw-args)
		      rest
		      expr ...)))
     ;; Positional argument
     ((_ name
	 (kw-args non-kw-args)
	 (binding . rest)
	 expr ...)
      (let ((binding (if (null? non-kw-args)
			 (error 'name "not enough arguments" non-kw-args)
			 (car non-kw-args)))
	    (cdr-non-kw-args (cdr non-kw-args)))
	(let-kwargs** name
		      (kw-args cdr-non-kw-args)
		      rest
		      expr ...)))
     ;; Rest argument
     ((_ name
	 (kw-args non-kw-args)
	 rest
	 expr ...)
      (let ((rest non-kw-args))
	expr ...))))

 ;; Simple wrapper to separate the kw/non-kw lists and pass it on to
 ;; further parsing
 (define-syntax let-kwargs*
   (syntax-rules ()
     ((_ name
	 ((binding . rest) args)
	 expr ...)
      (let-values (((kw-args non-kw-args) (split-kwargs args)))
	(let-kwargs** name
		      (kw-args non-kw-args)
		      (binding . rest)
		      expr ...)))))

 ;; Convenience syntax for defining kwargs functions
 (define-syntax define-kwproc
   (syntax-rules ()
     ((_ (name . argspec) expr ...)
      (define (name . args)
	(let-kwargs* name
		     (argspec args)
		     expr ...)))))

 )