HCoop / jackhill / mal.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge branch 'wasamasa-elisp'
[jackhill/mal.git] / elisp / core.el
CommitLineData
a09442e8
VS		 1(defun mal-seq-p (mal-object)
2 (let ((type (mal-type mal-object)))
3 (if (or (eq type 'list) (eq type 'vector))
c347c874
VS		 4 mal-true
5 mal-false)))
a09442e8
VS		 6
7(defun mal-listify (mal-object)
8 (let ((type (mal-type mal-object)))
9 (if (eq type 'vector)
4e1479b2
VS		 10 (append (mal-value mal-object) nil)
11 (mal-value mal-object))))
a09442e8 12
100fc40c
VS		 13(defun mal-= (a b)
14 (let ((a-type (mal-type a))
15 (b-type (mal-type b)))
16 (cond
17 ((and (and (not (eq a-type 'map))
18 (not (eq a-type 'list))
19 (not (eq a-type 'vector)))
20 (and (not (eq b-type 'map))
21 (not (eq b-type 'list))
22 (not (eq b-type 'vector))))
23 (mal-atom-= a b))
24 ((and (or (eq a-type 'list) (eq a-type 'vector))
25 (or (eq b-type 'list) (eq b-type 'vector)))
26 (mal-seq-= a b))
27 ((and (eq a-type 'map) (eq b-type 'map))
28 (mal-map-= a b))
29 (t
30 ;; incompatible types
31 nil))))
32
33(defun mal-atom-= (a b)
34 (equal (mal-value a) (mal-value b)))
35
36(defun mal-seq-= (a b)
37 (when (= (length (mal-value a))
38 (length (mal-value b)))
4e1479b2 39 (when (everyp 'mal-= (mal-listify a) (mal-listify b))
100fc40c
VS		 40 t)))
41
a09442e8
VS		 42(defun everyp (predicate list-a list-b)
43 (let ((everyp t))
44 (while (and everyp list-a list-b)
45 (let ((item-a (pop list-a))
46 (item-b (pop list-b)))
47 (when (not (funcall predicate item-a item-b))
48 (setq everyp nil))))
49 everyp))
50
100fc40c
VS		 51(defun mal-map-= (a b)
52 (catch 'return
53 (let ((a* (mal-value a))
54 (b* (mal-value b)))
55 (when (= (hash-table-count a*)
56 (hash-table-count b*))
57 (maphash (lambda (key a-value)
58 (let ((b-value (gethash key b*)))
59 (if b-value
60 (when (not (mal-= a-value b-value))
61 (throw 'return nil))
62 (throw 'return nil))))
63 a*)
64 ;; if we made it this far, the maps are equal
65 t))))
66
67(define-hash-table-test 'mal-= 'mal-= 'sxhash)
a09442e8 68
9927a29c
VS		 69(defun mal-conj (seq &rest args)
70 (let ((type (mal-type seq))
71 (value (mal-value seq)))
72 (if (eq type 'vector)
73 (mal-vector (vconcat (append (append value nil) args)))
74 (while args
75 (push (pop args) value))
76 (mal-list value))))
77
a09442e8 78(defvar core-ns
0aee14bb
VS		 79 `((+ . ,(mal-fn (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))))
80 (- . ,(mal-fn (lambda (a b) (mal-number (- (mal-value a) (mal-value b))))))
81 (* . ,(mal-fn (lambda (a b) (mal-number (* (mal-value a) (mal-value b))))))
82 (/ . ,(mal-fn (lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))))
83
c347c874
VS		 84 (< . ,(mal-fn (lambda (a b) (if (< (mal-value a) (mal-value b)) mal-true mal-false))))
85 (<= . ,(mal-fn (lambda (a b) (if (<= (mal-value a) (mal-value b)) mal-true mal-false))))
86 (> . ,(mal-fn (lambda (a b) (if (> (mal-value a) (mal-value b)) mal-true mal-false))))
87 (>= . ,(mal-fn (lambda (a b) (if (>= (mal-value a) (mal-value b)) mal-true mal-false))))
0aee14bb 88
c347c874 89 (= . ,(mal-fn (lambda (a b) (if (mal-= a b) mal-true mal-false))))
0aee14bb
VS		 90
91 (list . ,(mal-fn (lambda (&rest args) (mal-list args))))
c347c874
VS		 92 (list? . ,(mal-fn (lambda (mal-object) (if (mal-list-p mal-object) mal-true mal-false))))
93 (empty? . ,(mal-fn (lambda (seq) (if (zerop (length (mal-value seq))) mal-true mal-false))))
0aee14bb
VS		 94 (count . ,(mal-fn (lambda (seq) (mal-number (if (mal-seq-p seq) (length (mal-value seq)) 0)))))
95
96 (pr-str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat (lambda (item) (pr-str item t)) args " ")))))
97 (str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat 'pr-str args "")))))
c347c874
VS		 98 (prn . ,(mal-fn (lambda (&rest args) (println (mapconcat (lambda (item) (pr-str item t)) args " ")) mal-nil)))
99 (println . ,(mal-fn (lambda (&rest args) (println (mapconcat 'pr-str args " ")) mal-nil)))
0aee14bb
VS		 100
101 (read-string . ,(mal-fn (lambda (input) (read-str (mal-value input)))))
102 (slurp . ,(mal-fn (lambda (file)
103 (with-temp-buffer
104 (insert-file-contents-literally (mal-value file))
105 (mal-string (buffer-string))))))
106
107 (atom . ,(mal-fn (lambda (arg) (mal-atom arg))))
c347c874 108 (atom? . ,(mal-fn (lambda (mal-object) (if (mal-atom-p mal-object) mal-true mal-false))))
0aee14bb
VS		 109 (deref . ,(mal-fn (lambda (atom) (mal-value atom))))
110 (reset! . ,(mal-fn (lambda (atom value) (setf (aref atom 1) value))))
111 (swap! . ,(mal-fn (lambda (atom fn &rest args)
112 (let* ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn))
113 (args* (cons (mal-value atom) args))
114 (value (apply (mal-value fn*) args*)))
115 (setf (aref atom 1) value)))))
116
4e1479b2 117 (cons . ,(mal-fn (lambda (arg list) (mal-list (cons arg (mal-listify list))))))
39fd59a1 118 (concat . ,(mal-fn (lambda (&rest lists)
4e1479b2 119 (let ((lists* (mapcar (lambda (item) (mal-listify item)) lists)))
39fd59a1 120 (mal-list (apply 'append lists*))))))
1249126b
VS		 121
122 (nth . ,(mal-fn (lambda (seq index)
123 (let ((i (mal-value index))
4e1479b2 124 (list (mal-listify seq)))
1249126b 125 (or (nth i list)
9b0d9613 126 (error "Args out of range: %s, %d" (pr-str seq) i))))))
100fc40c
VS		 127 (first . ,(mal-fn (lambda (seq)
128 (if (mal-nil-p seq)
c347c874 129 mal-nil
4e1479b2 130 (let* ((list (mal-listify seq))
100fc40c 131 (value (car list)))
c347c874 132 (or value mal-nil))))))
4e1479b2 133 (rest . ,(mal-fn (lambda (seq) (mal-list (cdr (mal-listify seq))))))
100fc40c
VS		 134
135 (throw . ,(mal-fn (lambda (mal-object) (signal 'mal-custom (list mal-object)))))
136
137 (apply . ,(mal-fn (lambda (fn &rest args)
138 (let* ((butlast (butlast args))
139 (last (mal-listify (car (last args))))
140 (fn* (if (mal-func-p fn) (mal-func-fn fn) fn))
4e1479b2 141 (args* (append butlast last)))
100fc40c
VS		 142 (apply (mal-value fn*) args*)))))
143 (map . ,(mal-fn (lambda (fn seq)
144 (let ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn)))
145 (mal-list (mapcar (mal-value fn*) (mal-value seq)))))))
146
c347c874
VS		 147 (nil? . ,(mal-fn (lambda (arg) (if (mal-nil-p arg) mal-true mal-false))))
148 (true? . ,(mal-fn (lambda (arg) (if (mal-true-p arg) mal-true mal-false))))
149 (false? . ,(mal-fn (lambda (arg) (if (mal-false-p arg) mal-true mal-false))))
100fc40c 150
c347c874
VS		 151 (symbol? . ,(mal-fn (lambda (arg) (if (mal-symbol-p arg) mal-true mal-false))))
152 (keyword? . ,(mal-fn (lambda (arg) (if (mal-keyword-p arg) mal-true mal-false))))
153 (string? . ,(mal-fn (lambda (arg) (if (mal-string-p arg) mal-true mal-false))))
154 (vector? . ,(mal-fn (lambda (arg) (if (mal-vector-p arg) mal-true mal-false))))
155 (map? . ,(mal-fn (lambda (arg) (if (mal-map-p arg) mal-true mal-false))))
100fc40c
VS		 156
157 (symbol . ,(mal-fn (lambda (string) (mal-symbol (intern (mal-value string))))))
158 (keyword . ,(mal-fn (lambda (string) (mal-keyword (intern (concat ":" (mal-value string)))))))
159 (vector . ,(mal-fn (lambda (&rest args) (mal-vector (vconcat args)))))
160 (hash-map . ,(mal-fn (lambda (&rest args)
161 (let ((map (make-hash-table :test 'mal-=)))
162 (while args
163 (puthash (pop args) (pop args) map))
164 (mal-map map)))))
165
166 (sequential? . ,(mal-fn 'mal-seq-p))
167
c347c874
VS		 168 (get . ,(mal-fn (lambda (map key) (if (mal-map-p map) (or (gethash key (mal-value map)) mal-nil) mal-nil))))
169 (contains? . ,(mal-fn (lambda (map key) (if (gethash key (mal-value map)) mal-true mal-false))))
100fc40c
VS		 170 (assoc . ,(mal-fn (lambda (map &rest args)
171 (let ((map* (copy-hash-table (mal-value map))))
172 (while args
173 (puthash (pop args) (pop args) map*))
174 (mal-map map*)))))
175 (dissoc . ,(mal-fn (lambda (map &rest args)
176 (let ((map* (copy-hash-table (mal-value map))))
177 (while args
178 (remhash (pop args) map*))
179 (mal-map map*)))))
180 (keys . ,(mal-fn (lambda (map) (let (keys)
181 (maphash (lambda (key value) (push key keys))
182 (mal-value map))
183 (mal-list keys)))))
184 (vals . ,(mal-fn (lambda (map) (let (vals)
185 (maphash (lambda (key value) (push value vals))
186 (mal-value map))
187 (mal-list vals)))))
9927a29c 188
fde9d804
VS		 189 (readline . ,(mal-fn (lambda (prompt)
190 (let ((ret (readln (mal-value prompt))))
191 (if ret
192 (mal-string ret)
193 mal-nil)))))
9927a29c 194
c347c874 195 (meta . ,(mal-fn (lambda (mal-object) (or (mal-meta mal-object) mal-nil))))
9927a29c
VS		 196 (with-meta . ,(mal-fn (lambda (mal-object meta)
197 ;; TODO: doesn't work on hashtables
198 (let ((mal-object* (copy-tree mal-object t)))
199 (setf (aref mal-object* 2) meta)
200 mal-object*))))
201
202 (time-ms . ,(mal-fn (lambda () (mal-number (floor (* (float-time) 1000))))))
203
204 (conj . ,(mal-fn 'mal-conj))
205 (seq . ,(mal-fn (lambda (mal-object)
206 (let ((type (mal-type mal-object))
207 (value (mal-value mal-object)))
208 (cond
baec4b18
VS		 209 ((or (eq type 'list) (eq type 'vector))
210 (if (and value (not (zerop (length value))))
211 (mal-list (mal-listify mal-object))
c347c874 212 mal-nil))
9927a29c
VS		 213 ((eq type 'string)
214 (if (not (zerop (length value)))
215 (mal-list (mapcar (lambda (item) (mal-string (char-to-string item)))
216 (append value nil)))
c347c874 217 mal-nil))
9927a29c 218 (t
c347c874 219 mal-nil))))))
a09442e8 220 ))
Make a Lisp: jackhill's copy of https://github.com/kanaka/mal