defmulti/defmulti.carp at main · carpentry-org/defmulti · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
(defdynamic *defmulti-registry* {})

(defmodule Dynamic
  (defndynamic inverse [f]
    (fn [a] (not (f a))))

  (defmodule List
    (defndynamic take-while [f l]
      (cond
        (empty? l) '()
        (f (car l)) (cons (car l) (List.take-while f (cdr l)))
        '()))

    (defndynamic take [n l]
      (if (or (empty? l) (= 0 n))
        '()
        (cons (car l) (List.take (dec n) (cdr l)))))

    (defndynamic drop [n l]
      (if (or (empty? l) (= 0 n))
        l
        (List.drop (dec n) (cdr l))))
  )
)

(defndynamic defmulti-match-up [args params]
  (if (empty? params)
    (map cadr args)
    (if (list? (car params))
      (let [a (car args)
            i (List.find-index params (fn [pair] (= (car pair) (car a))))]
        (if (> i -1)
          (cons (cadr (List.nth params i)) (defmulti-match-up (cdr args) (List.remove-nth params i)))
          (cons (cadar args) (defmulti-match-up (cdr args) (cdr params)))))
      (cons (car params) (defmulti-match-up (cdr args) (cdr params))))))

(defndynamic defmulti-variable-resolve [name f args params]
  (if (> (length params) (length args))
    (macro-error (str "No arity " (length args) " version of " name " found!"))
    (let [no-positional (length (List.take-while (inverse list?) args))
          positional (List.take no-positional params)
          optional-args (List.drop no-positional args)
          optional-params (List.drop no-positional params)
          opt-args (defmulti-match-up optional-args optional-params)]
      (cons f (append positional opt-args)))))

(defndynamic defmulti-lookup [name args]
  (let [registry (Map.get *defmulti-registry* name)]
    (if (nil? registry)
      (macro-error "This shouldn’t happen! A defmulti error!")
      (let [f (Map.get registry (length args))]
        (if (nil? f)
          (let [f (Map.get registry 'variable)]
            (if (nil? f)
              (macro-error (str "No arity " (length args) " version of " name " found!"))
              (defmulti-variable-resolve name (car f) (cadr f) args)))
          (cons f args))))))

(defndynamic defmulti- [name forms]
  (if (empty? forms)
    '()
    (if (= (length forms) 1)
      (macro-error "Uneven number of forms in `defmulti`.")
      (let-do [s (gensym-with name)
               args (car forms)]
        (eval `(defn %s %(collect-into (map (fn [arg] (if (list? arg) (car arg) arg)) args) array) %(cadr forms)))
        (set! *defmulti-registry*
          (Map.put *defmulti-registry*
            name
            (Map.put
              (Map.get *defmulti-registry* name)
              (if (any? list? args) 'variable (length args))
              (if (any? list? args) (list s args) s))))
        (defmulti- name (cddr forms))))))

(defmacro defmulti [name :rest forms]
  (do
    (set! *defmulti-registry* (Map.put *defmulti-registry* name {}))
    (defmulti- name forms)
    (eval `(defmacro %name [:rest args] (defmulti-lookup (quote %name) args)))))