Both by-name and by-position per argument procedure calls.

name-and-pos.rkt

#lang racket
(require (for-syntax syntax/parse))

;;; Allow every argument to be passed by-name or by-position in a procedure call.
;;; Keywords do not need to apper in procedure headers in definitions.
;;; Accepts rest and keyword-rest arguments.
;;; A new definition of instantiate is also given to resemble this procedure call style.
;;; Resources:
;;; - http://www.mail-archive.com/[email protected]/msg08846.html
;;; - https://gist.github.com/Metaxal/5851215


#| Pros and Cons

** Pros:
- Everything that we previously used can still be used
  (by-position and by-name calling, rest arguments)
- Procedures that have multiple optional arguments can be called by specifying
  *only* the arguments for which we want to change the default value
- Wrappers and procedure extensions are easy to write
  (similar, in a limited way, to inheritence concepts in classes)
- We could make classes with instantiate look like exactly procedures,
  i.e., fields would be named by keywords.
  The same could be done for structs.
- A procedure can ask for rest-keywords without having to resort to `make-keyword-procedure' 
  which is not convenient
- 

** Cons:
- slightly slower? (not even sure?)
- ?

|#


#| TODO:
- Force some arguments to be by name only (i.e., give a keyword followed by a name)
- Received keyword-val dicts should have symbols instead of keywords?
  (i.e., keywords are actually only used in by-name calls?)
|#

(module+ test
  (require rackunit)
  (define (cvl proc . args)
    (call-with-values (λ () (apply proc args)) list))
  )

;; l1: (listof X?)
;; l2: (listof Y?)
;; <?: X? Y? -> boolean?
;; =?: X? Y? -> boolean?
;; select: X? Y? -> (listof Z?)
;; -> (listof X?) (listof Y?) (listof Z?)
;; Take two ordered lists, and returns the intersection and the remaining parts.
;; The elements of the intersection are selected among l1 and l2 with the select procedure
;; (by defaults, elements of the intersections are elements of l1).
(define (split l1 l2 
               #:<? [<? <] 
               #:=? [=? equal?]
               #:select [select (λ(a b)a)])
  (let loop ([l1 l1] 
             [l2 l2]
             [l1r '()] [l2r '()] [l12 '()])
    (cond [(empty? l2)
           (values (foldl cons l1 l1r) ; reverses l1r and appends l1 with it
                   (reverse l2r)
                   (reverse l12))]
          [(empty? l1)
           (values (reverse l1r)
                   (foldl cons l2 l2r)
                   (reverse l12))]
          [else (let ([a1 (first l1)] [a2 (first l2)])
                  (cond [(=? a1 a2)
                         (loop (rest l1) (rest l2) l1r l2r (cons (select a1 a2) l12))]
                        [(<? a1 a2)
                         (loop (rest l1) l2 (cons a1 l1r) l2r l12)]
                        [else 
                         (loop l1 (rest l2) l1r (cons a2 l2r) l12)]))])))

(module+ test
  (check-equal? (cvl split '(1 2 3) '(4 5 6))
                '((1 2 3) (4 5 6) ()))
  (check-equal? (cvl split '(1 2 3) '(2 5 6))
                '((1 3) (5 6) (2)))
  (check-equal? (cvl split '(1 2 3 5 7) '(2 4 5 6))
                '((1 3 7) (4 6) (2 5)))
  )

;; l1: (listof T?)
;; l2: (listof T?)
;; <?: T? T? -> boolean?
;; Returns the union of l1 and l2, sorted by <?.
;; l1 and l2 must be given sorted by <?.
(define (append-sorted l1 l2 [<? <])
  (let loop ([l1 l1] [l2 l2] [l '()])
    (cond [(empty? l1) (foldl cons l2 l)]
          [(empty? l2) (foldl cons l1 l)]
          [else (let ([a1 (first l1)] [a2 (first l2)])
                  (if (<? a1 a2)
                      (loop (rest l1) l2 (cons a1 l))
                      (loop l1 (rest l2) (cons a2 l))))])))

(module+ test
  (check-equal? (append-sorted '(1 3 6) '(2 4 5 7))
                '(1 2 3 4 5 6 7))
  )

;; known-kws: (listof keyword?) ; list of known keywords. Must be sorted by keyword<?
;; args: (listof any/c) ; by-position (input) arguments
;; ikws: (listof keyword?) ; input keyword. Must be sorted with keyword<?
;; ikw-vals: (listof any/c) ; value corresponding to the ikws keyword
;; -> kws kw-vals rst kwv-rst
;; ikws and ikw-vals must have the same length.
;; The convention 'kwv' means (listof keyword? any/c)
(define (split-args known-kws args ikws ikw-vals)
  ;(define known-kws '(#:a #:b #:c)) ; should be sorted
  (define-values (kwv-rst unused-kws1 used-kwvs)
    (split (map cons ikws ikw-vals) known-kws
           #:<? (λ (a b) (keyword<? (car a) b))
           #:=? (λ (a b) (eq? (car a) b))
           #;#;#:select (λ (a b) a)))
  ;(displayln (list 'kwv-rst: kwv-rst 'unused-kws1: unused-kws1 'used-kwvs: used-kwvs))
  
  (define-values (unused-kws rst used-kwv-args)
    (split unused-kws1 args
           #:=? (λ _ #t) #:select cons))
  ;(displayln (list 'rst: rst 'unused-kws unused-kws 'used-kwv-args: used-kwv-args))
  
  (define all-kwvs
    (append-sorted used-kwvs used-kwv-args 
                   (λ (a b) (keyword<? (car a) (car b)))))
  (define-values (okws okw-vals)
    (values (map car all-kwvs) 
            (map cdr all-kwvs)))
  
  (values okws okw-vals rst kwv-rst))

(module+ test
  (check-equal? (cvl split-args '() '() '() '())
                '(() () () ()))
  (check-equal? (cvl split-args '(#:a #:b) '() '() '())
                '(() () () ()))
  (check-equal? (cvl split-args '(#:a #:b #:c) '(a b c) '() '())
                '((#:a #:b #:c) (a b c) () ()))
  (check-equal? (cvl split-args '() '(a b c) '() '())
                '(() () (a b c) ()))
  (check-equal? (cvl split-args '(#:a #:b #:c) '() '(#:a #:b #:c) '(a b c))
                '((#:a #:b #:c) (a b c) () ()))
  (check-equal? (cvl split-args '(#:a #:b #:c) '(a c) '(#:b) '(b))
                '((#:a #:b #:c) (a b c) () ()))
  (check-equal? (cvl split-args '(#:a #:b #:c) '(a c d) '(#:b) '(b))
                '((#:a #:b #:c) (a b c) (d) ()))
  (check-equal? (cvl split-args '(#:a #:b #:c) '(a c) '(#:b #:d) '(b d))
                '((#:a #:b #:c) (a b c) () ((#:d . d))))
  )

;; mand-kws: list of mandatory keywords (currently unused)
;; opt-kws: list of optional keywords (currently unused)
;; known-kws: *ordered* list of the mandatory and optional keywords
(struct fun (proc mand-kws opt-kws known-kws kw-rest?)
  #:property prop:procedure
  (make-keyword-procedure 
   (λ(kws kw-args this . pos-args)
     ;(let-values ([(r a k) (args->kws+args this pos-args (map list kws kw-args))])
     (let-values ([(k v r rkv) (split-args (fun-known-kws this) pos-args kws kw-args)])
       (cond [(fun-kw-rest? this)
              (keyword-apply (fun-proc this) k v r #:kw-rest rkv)]
             [(empty? rkv)
              (keyword-apply (fun-proc this) k v r)]
             [else
              (error "Procedure does not take the following keywords:"
                     (map first rkv))])))))

(begin-for-syntax
  (define datum-symbol->keyword
    (compose string->keyword symbol->string syntax->datum))
  )

(define-syntax def-proc
  (syntax-parser
    [(_ (name x:id ... (y:id w:expr) ... (~optional (~seq #:kw-rest kw-rest:id)) . rst) body ...) 
     (let* ([xs (syntax->list #'(x ...))]
            [x-kws (map datum-symbol->keyword xs)]
            [xxs (foldr list* '() x-kws xs)]
            [xxs (if (attribute kw-rest) 
                     (list* '#:kw-rest #'kw-rest xxs)
                     xxs)]
            [ys (syntax->list #'(y ...))]
            [ws (syntax->list #'(w ...))]
            [y-kws (map datum-symbol->keyword ys)]
            [yys (foldr list* '() y-kws (map list ys ws))]
            [l (append xxs yys)]
            [known-kws (sort (append x-kws y-kws) keyword<?)]
            )
       (with-syntax ([x-kws x-kws] [y-kws y-kws] [known-kws known-kws]
                     [kw-rest? (if (attribute kw-rest) #'#t #'#f)])
         #`(define name (fun (λ (#,@l . rst) body ...)
                             'x-kws 'y-kws 'known-kws kw-rest?))))]))

(module+ test

  (def-proc (foo a b c [d 'dd] [e 'ee])
    (list a b c d e))

  (check-equal? (foo 'a 'b 'c)
                '(a b c dd ee))
  
  (check-equal? (foo 'a 'b 'c 'd 'e)
                '(a b c d e))
  
  (check-equal? (foo #:a 'a #:b 'b #:c 'c)
                '(a b c dd ee))
  
  (check-equal? (foo 'a 'b #:c 'c #:e 'e)
                '(a b c dd e))
  
  (check-equal? (foo 'a #:c 'c #:b 'b #:d 'd)
                '(a b c d ee))
  
  (check-equal? (foo #:b 'b #:c 'c #:e 'e #:a 'a )
                '(a b c dd e))
  
  (check-equal? (foo 'b 'c #:a 'a) ; bad style?
                '(a b c dd ee))
  
  (check-exn exn:fail? (λ () (foo))) ; too few arguments
  (check-exn exn:fail? (λ () (foo 1 2 3 #:t 't))) ; unknown keyword #:t
  (check-exn exn:fail? (λ () (foo 1 2 3 4 5 6))) ; too many arguments
  
  ; With a rest argument:
  (def-proc (bar x . rst) (list x rst))
  
  (check-equal? (bar 1) '(1 ()))
  (check-equal? (bar 1 2 3) '(1 (2 3)))
  (check-equal? (bar 1 #:x 2 3) '(2 (1 3)))
  
  ; With a keyword-rest argument:
  (def-proc (baz a [b 'b] #:kw-rest kw-rest)
    (list a b kw-rest))
  
  (check-equal? (baz 'a)
                '(a b ()))
  (check-equal? (baz 'a #:c 'c)
                '(a b ((#:c . c))))
  (check-equal? (baz 'a #:b 'bb)
                '(a bb ()))
  (check-equal? (baz 'a 'bb #:d 'd #:e 'e)
                '(a bb ((#:d . d) (#:e . e))))
  
  ; With both by-pos rest and keyword-rest arguments:
  (def-proc (qux a [b 'b] #:kw-rest kw-rest . rst)
    (list a b rst kw-rest))
  
  (check-equal? (qux 'a)
                '(a b () ()))
  (check-equal? (qux 'a 'bb 'd 'e #:c 'c)
                '(a bb (d e) ((#:c . c))))
  (check-equal? (qux 'a #:b 'bb 'c)
                '(a bb (c) ()))
  (check-equal? (qux 'a 'bb 'c 'f #:d 'd #:e 'e)
                '(a bb (c f) ((#:d . d) (#:e . e))))

  
  ; Defining a wrapper is very easy:
  ; (while keeping the other default arguments)
  (def-proc (foo2 [b 'bbb] #:kw-rest kw-rest . rst)
    (keyword-apply foo (map car kw-rest) (map cdr kw-rest) rst #:b b))
  
  (check-equal? (foo2 #:a 'a #:c 'c)
                '(a bbb c dd ee))
  (check-equal? (foo2 #:a 'a #:c 'c #:b 'bb)
                '(a bb c dd ee))
  
  ; Extending a proc is also very easy:
  (def-proc (foo3 x #:kw-rest kw-rest . rst)
    (list x (keyword-apply foo (map car kw-rest) (map cdr kw-rest) rst)))
  
  ;; Actually, the received keywords should only be the symbols, not the keywords,
  ;; and the conversion keyword<->symbol should be automatic, i.e., the user
  ;; uses keywords only in procedure calls, but receives symbols from #:kw-rest
  ;; and passes symbols to keyword-apply.
  ;; (?)
  )

;;; Making `instantiate' look like a procedure call:

(define-syntax my-instantiate
  (syntax-parser 
   [(_ cl v:expr ... (~seq k:keyword kv:expr) ...)
    (let ([l (map (λ (k kv) (list (string->symbol (keyword->string (syntax->datum k))) kv))
                  (syntax->list #'(k ...))
                  (syntax->list #'(kv ...)))])
      #`(instantiate cl
          (v ...)
          #,@l
          ))]))

(module+ test
  
  (define foo%
    (class object%
      (super-new)
      (init-field a b [c 'cc])
      (define/public (get) (list a b c))))
  
  (check-equal? (send (my-instantiate foo% #:b 'b #:a 'a) get)
                '(a b cc))
  (check-equal? (send (my-instantiate foo% 'a 'b) get)
                '(a b cc))
  (check-equal? (send (my-instantiate foo% 'a #:b 'b #:c 'c) get)
                '(a b c))
  )