; keywords.scm

; Bryan O'Sullivan <bosullvn@maths.tcd.ie> 12.94

; Revised 940208

; Code for providing Common Lisp-style keyword arguments.  This code
; assumes that defmacros are top-level in your Scheme implementation.
; It has been tested under SCM with SLIB, but should work with
; anything that supports SLIB.

; Oh, and note that this code is provided as is, without any guarantee
; (implied or otherwise) as to correctness or suitability for any
; particular use.

(require 'values)

(provide 'keywords)

; Convert a keyword symbol (a symbol with a colon at the end) into an
; ordinary symbol.

(define (keyword? symbol)
  (and (symbol? symbol) (let ((key-string (symbol->string keyword)))
			  (char=? (string-ref key-string
					      (- (string-length key-string) 1))
				  #\:))))

(define (keyword->symbol keyword)
  (if (symbol? keyword)
      (let* ((key-string (symbol->string keyword))
	     (colon-index (- (string-length key-string) 1)))
	(if (char=? (string-ref key-string colon-index) #\:)
	    (string->symbol (substring key-string 0 colon-index))
	    (error "keyword name does not end in colon --" keyword)))
      (error "keyword is not a symbol --" keyword)))

; Convert a list in which keys are followed by values into an
; association list, performing transformations on keys and values.

(define (list->alist list car-transformer cdr-transformer)
  (if (even? (length list))
      (let loop ((list list)
		 (acc '()))
	(if (null? list)
	    (reverse acc)
	    (let ((key (car-transformer (car list)))
		  (value (cdr-transformer (cadr list))))
	      (loop (cddr list)
		    (cons (cons key value) acc)))))
      (error "keyword list must be even in length --" list)))

; This gives us a new special form, simple-define-with-keywords.  It
; is used as follows:
;   (simple-define-with-keywords
;     (NAME KEY1: DEFAULT1 KEY2: DEFAULT2 ... KEYn: DEFAULTn)
;      BODY1
;      BODY2
;      ...
;      BODYm)

; You can then call NAME as follows:
;   (NAME KEYa: VALUEa KEYb: VALUEb ... KEYz: VALUEz)
; with KEYq evaluating to either VALUEq if it was given in the
; parameters to the call or DEFAULTq otherwise, in each BODYp.
; Defaults are only evaluated once each, at declaration time.

; For example:
;   (simple-define-with-keywords (foo a: 2 b: 5)
;     (+ a b))
;   (foo a: 7)  => 12
;   (foo)  => 7
;   (foo b: 6 a: 4)  => 10

(defmacro simple-define-with-keywords (formals . body)
  `(define ,(car formals)
     (let ((defaults ',(list->alist (cdr formals) keyword->symbol eval)))
       (defmacro foo arglist
	 (let ((givens (list->alist arglist
				    (lambda (key)
				      (let ((symbol (keyword->symbol key)))
					(if (assoc symbol defaults)
					    symbol
					    (error "undefined keyword --"
						   symbol))))
				    (lambda (_) _))))
	   `(let ,(map (lambda (pair)
			 (let* ((key (car pair))
				(given (assoc key givens)))
			   `(,key ,(cdr (if given given pair)))))
		       defaults)
	      ,@',body)))
       foo)))

(defmacro simple-lambda-with-keywords (formals . body)
  `(let ((defaults ',(list->alist (cdr formals) keyword->symbol eval)))
     (defmacro foo arglist
       (let ((givens (list->alist arglist
				  (lambda (key)
				    (let ((symbol (keyword->symbol key)))
				      (if (assoc symbol defaults)
					  symbol
					  (error "undefined keyword --"
						 symbol))))
				  (lambda (_) _))))
	 `(let ,(map (lambda (pair)
		       (let* ((key (car pair))
			      (given (assoc key givens)))
			 `(,key ,(cdr (if given given pair)))))
		     defaults)
	    ,@',body)))
     foo))

; Convert keyword list LIST into an association list, using
; DEFAULT-ALIST to prvoide default values for missing keywords.

(define (keyword-list->alist list default-alist)
  (let ((givens (list->alist list
			    (lambda (key)
			      (let ((symbol (keyword->symbol key)))
				(if (assoc symbol default-alist)
				    symbol
				    (error "keyword undefined in defaults --"
					   symbol))))
			    (lambda (_) _))))
    (map (lambda (pair)
	   (let* ((key (car pair))
		  (given (assoc key givens)))
	     (if given
		 (cons key (cdr given))
		 pair)))
	 default-alist)))

; For more features and fun with jiggery-pokery, we provide
; lambda-with-keywords.  How does it work?  It's much closer to
; expected Common Lisp behaviour than the very simple stuff above.
; You use it as follows:

; <lambda-expr> -> "(" "lambda-with-keywords" "(" <formal-args> ")" <body> ")"

; <formal-args> -> <var>* ("optional:" <more-arg>*)?
;                         ("rest:" <var>)?
;                         ("key:" <more-arg>*)?

; <more-arg>    -> <var>
;                | ( "(" <var> <expr> ")" )

; In the above grammar, <more-arg> indicates that you can provide a
; default value for optional and keyword formal arguments if no actual
; argument is given in a call.  If you do not, the default value is
; #f.  The "rest:" argument, if present, is bound to a list of all
; remaining actual arguments.

; When calling a form (it's not really a function) defined by
; lambda-with-keywords, you specify values for keyword arguments by
; prefixing each with the name of its argument, suffixed with a colon.
; Consider:

; (define fred-mbogo (lambda-with-keywords (a b key: i (j 4))
;                      (list a b i j)))
;   => #{unspecified}

; You can call it as follows:

; (fred-mbogo 17 'a i: 11)
;   => (17 'a 11 4)

; And that's more or less all there is to it.  Note that if you define
; both optional and keyword arguments to a function, all the optional
; actual arguments must be given if you give any keyword actual
; arguments in a call.  Consider:

; (define snark (lambda-with-keywords (a b optional: x key: i)
;                 (list a b x i)))
;   => #{unspecified}

; INCORRECT:
; (snark '(1 2 3) "foo" i: 11)

; CORRECT:
; (snark '(1 2 3) "foo" #\a i: 99)

; CORRECT:
; (snark #(4 6 8) "guppy")

; Note that because the semantics of eval in some implementations
; requires that its argument be evaluated in the top-level
; environment, lambda-with-keywords may not obey Scheme's lexical
; scoping rules.  I can't for the life of me think of any way around
; this.

(define lambda-orig lambda)

(define lambda-with-keywords
  (begin
    (defmacro substitute (formals . body)
      (call-with-values
       ;; Upon calling values below, the first argument to it consists
       ;; of a list of required argument names.  The second consists
       ;; of an alist of (NAME . VALUE) pairs for optional arguments.
       ;; The third gives a name to which to bind any remaining
       ;; arguments, or #f if we don't want any, and the last argument
       ;; also consists of an alist of (NAME . VALUE) pairs.
       (lambda-orig ()
	 (let r-loop ((formals formals)
		      (reals '()))
	   (if (null? formals)
	       (values (reverse reals) '() #f '())
	       (let ((formal (car formals)))
		 (if (member formal '(optional: rest: key:))
		     (let o-loop ((formals (if (equal? formal 'optional:)
					       (cdr formals)
					       formals))
				  (optionals '()))
		       (if (null? formals)
			   (values (reverse reals) (reverse optionals) #f '())
			   (let ((formal (car formals)))
			     (if (member formal '(rest: key:))
				 (let* ((is-rest (equal? formal 'rest:))
					(rest (if is-rest
						  (cadr formals)
						  #f)))
				   (let k-loop ((formals
						 (if is-rest
						     (let ((fs (cddr formals)))
						       (if (null? fs)
							   fs
							   (cdr fs)))
						     (cdr formals)))
						(keys '()))
				     (if (null? formals)
					 (values (reverse reals)
						 (reverse optionals)
						 rest
						 (reverse keys))
					 ;; We want to eval default
					 ;; values right here.  If we
					 ;; don't, lexical scoping
					 ;; gets nuked.
					 (let ((formal (car formals)))
					   (k-loop (cdr formals)
						   (cons
						    (if (list? formal)
							(cons (car formal)
							      (eval (list 'quote
								     (cadr formal))))
							(cons formal #f))
						    keys))))))
				 (o-loop (cdr formals)
					 (cons (if (list? formal)
						   (cons (car formal)
							 (eval (list 'quote (cadr formal))))
						   (cons formal #f))
					       optionals))))))
		     (r-loop (cdr formals)
			     (cons formal reals)))))))
       (lambda-orig (reals optionals rest keys)
	 `(let ((keys ',keys)
		(rest ',rest))
	    (defmacro foo actuals
	      `(let ,(let r-loop ((reals ',reals)
				  (actuals actuals)
				  (bindings '()))
		       (if (null? reals)
			   (let o-loop ((optionals ',optionals)
					(actuals actuals)
					(bindings bindings))
			     (cond
			      ((null? actuals)
			       (append (if rest (list (list rest #f)) '())
				       bindings
				       (map (lambda-orig (optional)
					      (list (car optional)
						    (cdr optional)))
					    optionals)
				       (reverse (map (lambda-orig (key)
						       (list (car key)
							     ;; call cdr
							     (cdr key)))
						     keys))))
			      ((null? optionals)
			       (let ((actuals (list->alist actuals
							   keyword->symbol
							   (lambda-orig (_)
							     _))))
				 (append (map (lambda-orig (default)
						(let* ((lkup (assoc
							      (car default)
							      actuals))
						       (thing (if lkup
								  lkup
								  default)))
						  (list (car thing)
							(cdr thing))))
					      keys)
					 (if rest
					     `((,rest (quote
						       ,(map cdr actuals))))
					     '())
					 bindings)))
			      (else
			       (o-loop (cdr optionals)
				       (cdr actuals)
				       (cons (list (caar optionals)
						   (car actuals))
					     bindings)))))
			   (r-loop (cdr reals)
				   (cdr actuals)
				   (cons (list (car reals)
					       (car actuals))
					 bindings))))
		 ,@',body))
	    foo))))
    substitute))

; We provide define-with-keywords as sugar for lambda-with-keywords.
; For example:

; (define-with-keywords (glark a optional: x)
;   (list a x))
;   => #{unspecified}

; (glark 1)
;   => (1 #f)

(define define-orig define)

(define define-with-keywords
  (begin
    (defmacro substitute (formals . body)
      `(define-orig ,(car formals)
         (lambda-with-keywords ,(cdr formals)
           ,@body)))
    substitute))