1#lang racket/base
2(provide (struct-out arguments)
3         (struct-out arity)
4         no-arguments
5         no-arity
6         to-procedure-arity
7         arguments->arity
8         check-arity
9         check-curry
10         join-sep
11         kw->string
12         diff/sorted/eq)
13
14#|
15An Arguments is
16  #s(arguments (listof stx) (listof keyword) (listof stx))
17|#
18(define-struct arguments (pargs kws kwargs) #:prefab)
19
20(define no-arguments (arguments null null null))
21
22#|
23An Arity is
24  #s(arity nat nat/+inf.0 (listof keyword) (listof keyword))
25|#
26(define-struct arity (minpos maxpos minkws maxkws)
27  #:prefab)
28
29(define no-arity (arity 0 0 null null))
30
31;; ----
32
33(define (to-procedure-arity minpos maxpos)
34  (cond [(= minpos maxpos) minpos]
35        [(= maxpos +inf.0) (arity-at-least minpos)]
36        [else (for/list ([i (in-range minpos (add1 maxpos))]) i)]))
37
38(define (arguments->arity argu)
39  (let ([pos (length (arguments-pargs argu))]
40        [kws (arguments-kws argu)])
41    (arity pos pos kws kws)))
42
43(define (check-arity arity pos-count keywords0 proc)
44  (define keywords (sort keywords0 keyword<?))
45  (define minpos (arity-minpos arity))
46  (define maxpos (arity-maxpos arity))
47  (define minkws (arity-minkws arity))
48  (define maxkws (arity-maxkws arity))
49  (unless (<= minpos pos-count maxpos)
50    (proc (format "syntax class arity mismatch~a\n  expected: ~a\n  given: ~a"
51                  ";\n the expected number of arguments does not match the given number"
52                  (gen-expected-msg minpos maxpos minkws maxkws)
53                  (gen-given-msg pos-count keywords))))
54  (let ([missing-kws (diff/sorted/eq minkws keywords)])
55    (unless (null? missing-kws)
56      (proc (format "syntax class required keyword argument~a not supplied\n  required: ~a"
57                    (s-if-plural missing-kws)
58                    (join-sep (map kw->string missing-kws) "," "and")))))
59  (let ([extra-kws (diff/sorted/eq keywords maxkws)])
60    (unless (null? extra-kws)
61      (proc (format "syntax class does not expect given keyword argument~a\n  given: ~a"
62                    (s-if-plural extra-kws)
63                    (join-sep (map kw->string extra-kws) "," "and"))))))
64
65(define (gen-expected-msg minpos maxpos minkws maxkws)
66  (define pos-part
67    (cond [(= minpos maxpos) (format "~s" minpos)]
68          [(eqv? maxpos +inf.0) (format "at least ~s" minpos)]
69          [else (format "between ~s and ~s" minpos maxpos)]))
70  (define kws-part
71    (cond [(pair? minkws)
72           (format " plus keyword argument~a ~a"
73                   (s-if-plural minkws)
74                   (join-sep (map kw->string minkws) "," "and"))]
75          [else ""]))
76  (define optkws (diff/sorted/eq maxkws minkws))
77  (define optkws-part
78    (cond [(pair? optkws)
79           (format " plus optional keyword argument~a ~a"
80                   (s-if-plural optkws)
81                   (join-sep (map kw->string minkws) "," "and"))]
82          [else ""]))
83  (string-append pos-part kws-part optkws-part))
84
85(define (gen-given-msg pos-count kws)
86  (define kws-part
87    (cond [(pair? kws)
88           (format " plus keyword argument~a ~a"
89                   (s-if-plural kws)
90                   (join-sep (map kw->string kws) "," "and"))]
91          [else ""]))
92  (format "~s~a" pos-count kws-part))
93
94;; ----
95
96(define (check-curry arity pos-count keywords proc)
97  (let ([maxpos (arity-maxpos arity)]
98        [maxkws (arity-maxkws arity)])
99    (when (> pos-count maxpos)
100      (proc (format "too many arguments\n  expected: at most ~s\n  given: ~s"
101                    maxpos pos-count)))
102    (let ([extrakws (diff/sorted/eq keywords maxkws)])
103      (when (pair? extrakws)
104        (proc (format "syntax class does not expect given keyword arguments\n  given keywords: ~a"
105                      (join-sep (map kw->string extrakws) "," "and")))))))
106
107;; ----
108
109(define (kw->string kw) (format "~a" kw))
110
111(define (diff/sorted/eq xs ys)
112  (if (pair? xs)
113      (let ([ys* (memq (car xs) ys)])
114        (if ys*
115            (diff/sorted/eq (cdr xs) (cdr ys*))
116            (cons (car xs) (diff/sorted/eq (cdr xs) ys))))
117      null))
118
119(define (join-sep items sep0 ult0 [prefix ""])
120  (define sep (string-append sep0 " "))
121  (define ult (string-append ult0 " "))
122  (define (loop items)
123    (cond [(null? items)
124           null]
125          [(null? (cdr items))
126           (list sep ult (car items))]
127          [else
128           (list* sep (car items) (loop (cdr items)))]))
129  (case (length items)
130    [(0) #f]
131    [(1) (string-append prefix (car items))]
132    [(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
133    [else (let ([strings (list* (car items) (loop (cdr items)))])
134            (apply string-append prefix strings))]))
135
136(define (s-if-plural xs) (if (= (length xs) 1) "" "s"))
137