;;
;; racket-kwargs.scm
;;
;; CHICKEN Scheme version of Racket define/lambda for procedures with
;; mandatory and optional keyword arguments as well as positional and
;; optional arguments anywhere in the argument list. The only
;; limiation being that mandatory positional argument must not be
;; specified after any optional positional argument.
;;
;; 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 racket-kwargs))

(module
 racket-kwargs
 (
  lambda*
  define*
  )

 (import scheme
	 (chicken base)
	 (chicken keyword)
	 (chicken syntax)
	 (chicken format))

 (begin-for-syntax
  (import (chicken keyword)))

 ;; Splits arguments into two lists: the kw-args and non-kw-args. This
 ;; procedure is used during run-time to parse the procedure arguments
 ;; and supply values to the argument bindings. The keyword arguments
 ;; are returned in reverse order, the positional arguments are
 ;; returned in the same order as given.
 (define-syntax split-kwargs
   (syntax-rules ()
     ((_ name 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 'name
			   "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))))))))

 ;; Conditional expansion if given term is an identifier - taken from
 ;; SRFI-57 sample implementation:
 ;; https://srfi.schemers.org/srfi-57/srfi-57-1.2.html
 (define-syntax if-id?
   (syntax-rules ()
     ((_ (x . y)  sk fk) fk)
     ((_ #(x ...) sk fk) fk)
     ((_ x sk fk)
      (let-syntax ((test (syntax-rules ()
                           ((test x sk* fk*)     sk*)
                           ((test non-x sk* fk*) fk*))))
	(test foo sk fk)))))

 ;; Conditional expansion for quoted symbols.
 (define-syntax if-symbol?
   (syntax-rules (quote)
     ((_ (quote (x . y)) sk fk) fk)
     ((_ (quote x) sk fk)
      (let-syntax ((test (syntax-rules ()
                           ((test x sk* fk*)     sk*)
                           ((test non-x sk* fk*) fk*))))
	(test x sk fk)))
     ((_ x sk fk) fk)))

 ;; Conditional expansion if keyword is given.
 (define-syntax if-keyword?
  (ir-macro-transformer
   (lambda (e i c)
     (if (keyword? (cadr e))
	 (caddr e)
	 (cadddr e)))))

 ;; Conditional expansion for list expressions
 (define-syntax if-list?
   (syntax-rules ()
     ((_ (w x ...) t f)
      (if-symbol? (w x ...) f t))
     ((_ x t f) f)))

 ;; Expansion-time conditional expansion based on boolean constant.
 (define-syntax if-true?
   (syntax-rules ()
     ((_ #f t f) f)
     ((_ #t t f) t)))

 ;; Allows extracting file:line information from within syntax-rules
 ;; templates.
 (define-syntax expansion-line
   (er-macro-transformer
    (lambda (e i c)
      (get-line-number e))))

 ;; Creates one binding without default value from non-kw-args list
 ;; and resumes argument processing.
 (define-syntax let-id-arg*
   (syntax-rules ()
     ((_ name
	 seen-opt?
	 (kws nkws)
	 (id . rest)
	 all-kws
	 body ...)
      (if-true? seen-opt?
		(begin-for-syntax
		 (syntax-error
		  (let ((el (expansion-line id)))
		    (format "~A~A~A - positional argument after optional: ~A"
			    (or el "")
			    (if el " " "")
			    'name 'id))))
		(if (null? nkws)
		    (error "not enough arguments given" 'name)
		    (let ((id (car nkws)))
		      (let-args** name
				  seen-opt?
				  (kws (cdr nkws))
				  rest
				  all-kws
				  body ...)))))))

 ;; Creates one binding with default value.
 (define-syntax let-idd-arg*
   (syntax-rules ()
     ((_ name
	 seen-opt?
	 (kws nkws)
	 ((id def) . rest)
	 all-kws
	 body ...)
      (let ((id (if (null? nkws)
		    def
		    (car nkws))))
	(let-args** name
		    #t
		    (kws (if (null? nkws)
			     nkws
			     (cdr nkws)))
		    rest
		    all-kws
		    body ...)))))

 ;; Create bindings for mandatory and optional keyword arguments.
 (define-syntax let-kw-arg*
   (syntax-rules ()
     ((_ name
	 seen-opt?
	 (kws nkws)
	 (kw (id def) . rest)
	 (all-kws ...)
	 body ...)
      (let ((id (get-keyword kw kws (lambda () def))))
	(let-args** name
		    seen-opt?
		    (kws nkws)
		    rest
		    (kw all-kws ...)
		    body ...)))
     ((_ name
	 seen-opt?
	 (kws nkws)
	 (kw (id . restd) . rest)
	 (all-kws ...)
	 body ...)
      (begin-for-syntax
       (syntax-error
	(let ((el (expansion-line name)))
	  (format "~A~A~A - wrong keyword argument syntax: ~A ~A"
		  (or el "")
		  (if el " " "")
		  'name kw '(id . restd))))))
     ((_ name
	 seen-opt?
	 (kws nkws)
	 (kw id . rest)
	 (all-kws ...)
	 body ...)
      (let ((id (get-keyword kw kws (lambda ()
				      (error 'name "missing kw argument"
					     kw)))))
	(let-args** name
		    seen-opt?
		    (kws nkws)
		    rest
		    (kw all-kws ...)
		    body ...)))
     ((_ name
	 seen-opt?
	 (kws nkws)
	 (kw)
	 (all-kws ...)
	 body ...)
      (begin-for-syntax
       (syntax-error
	(let ((el (expansion-line name)))
	  (format "~A~A~A - missing keyword argument syntax: ~A"
		  (or el "")
		  (if el " " "")
		  'name kw)))))))

 ;; Checks whether only defined keywords are used.
 (define-syntax check-kws
   (syntax-rules ()
     ((_ name (all-kws ...) kw-args)
      (let ((kws-list (list all-kws ...)))
	(let loop ((kws (let kloop ((kw-args kw-args)
				    (res '()))
			  (if (null? kw-args)
			      res
			      (kloop (cddr kw-args)
				     (cons (car kw-args) res))))))
	  (when (not (null? kws))
	    (if (not (memq (car kws) kws-list))
		(error 'name "unknown keyword argument" (car kws))
		(loop (cdr kws)))))))))

 ;; Converts argument specifications into set of nested let bindings.
 (define-syntax let-args**
   (syntax-rules ()
     ;; End, without rest
     ((_ name
	 seen-opt?
	 (kw-args non-kw-args)
	 ()
	 all-kws
	 body ...)
      (if (null? non-kw-args)
	  (let ()
	    (check-kws name all-kws kw-args)
	    body ...)
	  (error 'name "too many arguments" non-kw-args)))
     ;; Dispatch to appropriate sub-syntax
     ((_ name
	 seen-opt?
	 (kw-args non-kw-args)
	 (expr . rest)
	 all-kws
	 body ...)
      (if-list? expr
		(let-idd-arg* name
			      seen-opt?
			      (kw-args non-kw-args)
			      (expr . rest)
			      all-kws
			      body ...)
		(if-id? expr
			(let-id-arg* name
				     seen-opt?
				     (kw-args non-kw-args)
				     (expr . rest)
				     all-kws
				     body ...)
			(if-keyword? expr
				     (let-kw-arg* name
						  seen-opt?
						  (kw-args non-kw-args)
						  (expr . rest)
						  all-kws
						  body ...)
				     (begin-for-syntax
				      (syntax-error
				       (let ((el (expansion-line name)))
					 (format
					  "~A~A~A - keyword, identifier or list required: ~A~A"
					  (or el "")
					  (if el " " "")
					  'name
					  (if-symbol? expr
						      "'"
						      "")
					  expr))))))))
     ;; End of the argspec with rest binding
     ((_ name
	 seen-opt?
	 (kw-args non-kw-args)
	 rest
	 all-kws
	 body ...)
      (let ((rest non-kw-args))
	(check-kws name all-kws kw-args)
	body ...))))

 ;; The outermost expression of the lambda* syntax that uses split
 ;; keyword/non-keyword argument lists as source for keyword argument
 ;; values lookup and positional arguments consumption.
 (define-syntax let-args*
   (syntax-rules ()
     ((_ name
	 (argspecs args)
	 body ...)
      (let-values (((kw-args non-kw-args) (split-kwargs name args)))
	(let-args** name
		    #f
		    (kw-args non-kw-args)
		    argspecs
		    ()
		    body ...)))))

 ;; Named lambda-like syntax that creates a procedure that handles
 ;; positional and keyword arguments separately, creating the
 ;; procedure in a way that introduces appropriate bindings for the
 ;; body ... expressions.
 (define-syntax lambda**
   (syntax-rules ()
     ((_ (name . argspecs) body ...)
      (lambda args
	(let-args* name
		   (argspecs args)
		   body ...)))))

 ;; This is a wrapper around lambda** that omits
 ;; actual name for error reporting.
 (define-syntax lambda*
   (syntax-rules ()
     ((_ argspecs body ...)
      (lambda** (lambda* . argspecs) body ...))))

 ;; Simple wrapper that behaves like define syntax but for lambda form
 ;; it uses lambda* syntax.
 (define-syntax define*
   (syntax-rules ()
     ((_ (name . argspecs) body ...)
      (define name
	(lambda** (name . argspecs)
		  body ...)))
     ((_ i v)
      (define i v))))

 )