From 3d567f643c640dd8bbac8ba2e1e847245e8c2fc4 Mon Sep 17 00:00:00 2001
From: Leif Andersen <leif@leifandersen.net>
Date: Sat, 4 Oct 2014 22:00:08 -0400
Subject: [PATCH] Puts following limitations on args:

* no duplicate names
* no duplicate keywords
* no mandatory argument after optional argument
---
 .../syntax/parse/lib/function-header.rkt      | 98 +++++++++++++++++--
 1 file changed, 90 insertions(+), 8 deletions(-)

diff --git a/racket/collects/syntax/parse/lib/function-header.rkt b/racket/collects/syntax/parse/lib/function-header.rkt
index 4343597e03..4f4ce63833 100644
--- a/racket/collects/syntax/parse/lib/function-header.rkt
+++ b/racket/collects/syntax/parse/lib/function-header.rkt
@@ -1,9 +1,10 @@
 #lang racket/base
 
 (require "../../parse.rkt"
-         "../experimental/template.rkt")
+         "../experimental/template.rkt"
+         racket/dict)
 
-(provide (all-defined-out))
+(provide function-header arg args)
 
 (define-syntax-class function-header
   (pattern ((~or header:function-header name:id) . args:args)
@@ -12,15 +13,96 @@
                       . args.params))))
 
 (define-syntax-class args
+  #:attributes (params)
   (pattern (arg:arg ...)
-           #:attr params #'(arg.name ...))
+           #:attr params #'(arg.name ...)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+           "duplicate argument name"
+           #:fail-when (check-duplicate (syntax->list #'(arg.kw ...))
+                                        #:key (λ (x)
+                                                (syntax->datum x))
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? x y))))
+           "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (syntax->list #'((arg.name arg.default) ...)))
+           "default-value expression missing")
   (pattern (arg:arg ... . rest:id)
-           #:attr params #'(arg.name ... rest)))
+           #:attr params #'(arg.name ... rest)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+           "duplicate argument name"
+           #:fail-when (check-duplicate (syntax->list #'(arg.kw ...))
+                                        #:key (λ (x)
+                                                (syntax->datum x))
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? x y))))
+           "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (syntax->list #'((arg.name arg.default) ...)))
+           "default-value expression missing"))
 
 (define-splicing-syntax-class arg
-  #:attributes (name)
-  (pattern name:id)
-  (pattern [name:id default])
-  (pattern (~seq kw:keyword name:id))
+  #:attributes (name kw default)
+  (pattern name:id
+           #:attr kw #'#f
+           #:attr default #'#f)
+  (pattern [name:id default]
+           #:attr kw #'#f)
+  (pattern (~seq kw:keyword name:id)
+           #:attr default #'#f)
   (pattern (~seq kw:keyword [name:id default])))
 
+(define (invalid-option-placement optional-list)
+  (define iop
+    (for/fold ([status      'required])
+              ([i optional-list]
+               #:break (syntax? status))
+      (define i* (syntax->list i))
+      ;(match* (status (syntax->datum (cadr i*)))
+      (cond [(eq? status 'required)
+             (cond [(syntax->datum (cadr i*)) 'optional]
+                   [else                      'required])]
+            [else
+             (cond [(syntax->datum (cadr i*)) 'optional]
+                   [else                      (car i*)])])))
+  (if (syntax? iop) iop #f))
+
+;; Copied from unstable/list
+;; check-duplicate : (listof X)
+;;                   #:key (X -> K)
+;;                   #:same? (or/c (K K -> bool) dict?)
+;;                -> X or #f
+(define (check-duplicate items
+                        #:key [key values]
+                        #:same? [same? equal?])
+  (cond [(procedure? same?)
+         (cond [(eq? same? equal?)
+                (check-duplicate/t items key (make-hash) #t)]
+               [(eq? same? eq?)
+                (check-duplicate/t items key (make-hasheq) #t)]
+               [(eq? same? eqv?)
+                (check-duplicate/t items key (make-hasheqv) #t)]
+               [else
+                (check-duplicate/list items key same?)])]
+        [(dict? same?)
+         (let ([dict same?])
+           (if (dict-mutable? dict)
+               (check-duplicate/t items key dict #t)
+               (check-duplicate/t items key dict #f)))]))
+(define (check-duplicate/t items key table mutating?)
+  (let loop ([items items] [table table])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (dict-ref table key-item #f)
+               (car items)
+               (loop (cdr items) (if mutating?
+                                     (begin (dict-set! table key-item #t) table)
+                                     (dict-set table key-item #t))))))))
+(define (check-duplicate/list items key same?)
+  (let loop ([items items] [sofar null])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (for/or ([prev (in-list sofar)])
+                 (same? key-item prev))
+               (car items)
+               (loop (cdr items) (cons key-item sofar)))))))