[jackhill/mal.git] / scheme / lib / core.sld

(define-library (lib core)

(export ns)

(import (scheme base))
(import (scheme write))
(import (scheme file))
(import (scheme time))
(import (scheme read))
(import (scheme eval))
;; HACK: cyclone doesn't implement environments yet, but its eval
;; behaves as if you were using the repl environment
(cond-expand
 (cyclone)
 (else
  (import (scheme repl))))

(import (lib types))
(import (lib util))
(import (lib printer))
(import (lib reader))

(begin

(define (coerce x)
  (if x mal-true mal-false))

(define (->printed-string args print-readably sep)
  (let ((items (map (lambda (arg) (pr-str arg print-readably)) args)))
    (string-intersperse items sep)))

(define (mal-equal? a b)
  (let ((a-type (and (mal-object? a) (mal-type a)))
        (a-value (and (mal-object? a) (mal-value a)))
        (b-type (and (mal-object? b) (mal-type b)))
        (b-value (and (mal-object? b) (mal-value b))))
    (cond
     ((or (not a-type) (not b-type))
      mal-false)
     ((and (memq a-type '(list vector))
           (memq b-type '(list vector)))
      (mal-list-equal? (->list a-value) (->list b-value)))
     ((and (eq? a-type 'map) (eq? b-type 'map))
      (mal-map-equal? a-value b-value))
     (else
      (and (eq? a-type b-type)
           (equal? a-value b-value))))))

(define (mal-list-equal? as bs)
  (let loop ((as as)
             (bs bs))
    (cond
     ((and (null? as) (null? bs)) #t)
     ((or (null? as) (null? bs)) #f)
     (else
      (if (mal-equal? (car as) (car bs))
          (loop (cdr as) (cdr bs))
          #f)))))

(define (mal-map-ref key m . default)
  (if (pair? default)
      (alist-ref key m mal-equal? (car default))
      (alist-ref key m mal-equal?)))

(define (mal-map-equal? as bs)
  (if (not (= (length as) (length bs)))
      #f
      (let loop ((as as))
        (if (pair? as)
            (let* ((item (car as))
                   (key (car item))
                   (value (cdr item)))
              (if (mal-equal? (mal-map-ref key bs) value)
                  (loop (cdr as))
                  #f))
            #t))))

(define (mal-map-dissoc m keys)
  (let loop ((items m)
             (acc '()))
    (if (pair? items)
        (let* ((item (car items))
               (key (car item)))
          (if (contains? keys (lambda (x) (mal-equal? key x)))
              (loop (cdr items) acc)
              (loop (cdr items) (cons item acc))))
        (reverse acc))))

(define (mal-map-assoc m kvs)
  (let ((kvs (list->alist kvs)))
    (append kvs (mal-map-dissoc m (map car kvs)))))

(define (map-in-order proc items)
  (let loop ((items items)
             (acc '()))
    (if (null? items)
        (reverse acc)
        (loop (cdr items) (cons (proc (car items)) acc)))))

(define (slurp path)
  (call-with-output-string
   (lambda (out)
     (call-with-input-file path
       (lambda (in)
         (let loop ()
           (let ((chunk (read-string 1024 in)))
             (when (not (eof-object? chunk))
               (display chunk out)
               (loop)))))))))

(define (time-ms)
  (* (/ (current-jiffy) (jiffies-per-second)) 1000.0))

(define (->mal-object x)
  (cond
   ((boolean? x) (if x mal-true mal-false))
   ((char? x) (mal-string (char->string x)))
   ((procedure? x) x)
   ((symbol? x) (mal-symbol x))
   ((number? x) (mal-number x))
   ((string? x) (mal-string x))
   ((or (null? x) (pair? x))
    (mal-list (map ->mal-object x)))
   ((vector? x)
    (mal-vector (vector-map ->mal-object x)))
   (else
    (error "unknown type"))))

(define (scm-eval input)
  (call-with-input-string input
    (lambda (port)
      (cond-expand
       (cyclone
        (->mal-object (eval (read port))))
       (else
        (->mal-object (eval (read port) (environment '(scheme base)
                                                     '(scheme write)))))))))

(define ns
  `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
    (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
    (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
    (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))

    (list . ,(lambda args (mal-list args)))
    (list? . ,(lambda (x) (coerce (mal-instance-of? x 'list))))
    (empty? . ,(lambda (lis) (coerce (null? (->list (mal-value lis))))))
    (count . ,(lambda (lis) (mal-number
                             (if (eq? lis mal-nil)
                                 0
                                 (length (->list (mal-value lis)))))))

    (< . ,(lambda (a b) (coerce (< (mal-value a) (mal-value b)))))
    (<= . ,(lambda (a b) (coerce (<= (mal-value a) (mal-value b)))))
    (> . ,(lambda (a b) (coerce (> (mal-value a) (mal-value b)))))
    (>= . ,(lambda (a b) (coerce (>= (mal-value a) (mal-value b)))))
    (= . ,(lambda (a b) (coerce (mal-equal? a b))))

    (pr-str . ,(lambda args (mal-string (->printed-string args #t " "))))
    (str . ,(lambda args (mal-string (->printed-string args #f ""))))
    (prn . ,(lambda args
              (display (->printed-string args #t " "))
              (newline)
              mal-nil))
    (println . ,(lambda args
                  (display (->printed-string args #f " "))
                  (newline)
                  mal-nil))

    (read-string . ,(lambda (string) (read-str (mal-value string))))
    (slurp . ,(lambda (path) (mal-string (slurp (mal-value path)))))
    (throw . ,(lambda (x) (raise (cons 'user-error x))))
    (readline . ,(lambda (prompt) (let ((output (readline (mal-value prompt))))
                                    (if output (mal-string output) mal-nil))))
    (time-ms . ,(lambda () (mal-number (time-ms))))
    (scm-eval . ,(lambda (input) (scm-eval (mal-value input))))

    (atom . ,(lambda (x) (mal-atom x)))
    (atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom))))
    (deref . ,(lambda (atom) (mal-value atom)))
    (reset! . ,(lambda (atom x) (mal-value-set! atom x) x))
    (swap! . ,(lambda (atom fn . args)
                (let* ((fn (if (func? fn) (func-fn fn) fn))
                       (value (apply fn (cons (mal-value atom) args))))
                  (mal-value-set! atom value)
                  value)))

    (cons . ,(lambda (x xs) (mal-list (cons x (->list (mal-value xs))))))
    (concat . ,(lambda args (mal-list (apply append (map (lambda (arg) (->list (mal-value arg))) args)))))
    (nth . ,(lambda (x n) (let ((items (->list (mal-value x)))
                                (index (mal-value n)))
                            (if (< index (length items))
                                (list-ref items index)
                                (error (str "Out of range: " index))))))
    (first . ,(lambda (x) (if (eq? x mal-nil)
                              mal-nil
                              (let ((items (->list (mal-value x))))
                                (if (null? items)
                                    mal-nil
                                    (car items))))))
    (rest . ,(lambda (x) (if (eq? x mal-nil)
                             (mal-list '())
                             (let ((items (->list (mal-value x))))
                               (if (null? items)
                                   (mal-list '())
                                   (mal-list (cdr items)))))))
    (conj . ,(lambda (coll . args)
               (let ((items (mal-value coll)))
                 (cond
                  ((vector? items)
                   (mal-vector (vector-append items (list->vector args))))
                  ((list? items)
                   (mal-list (append (reverse args) items)))
                  (else
                   (error "invalid collection type"))))))
    (seq . ,(lambda (x) (if (eq? x mal-nil)
                            mal-nil
                            (let ((value (mal-value x)))
                              (case (mal-type x)
                                ((list)
                                 (if (null? value)
                                     mal-nil
                                     x))
                                ((vector)
                                 (if (zero? (vector-length value))
                                     mal-nil
                                     (mal-list (vector->list value))))
                                ((string)
                                 (if (zero? (string-length value))
                                     mal-nil
                                     (mal-list (map mal-string (explode value)))))
                                (else
                                 (error "invalid collection type")))))))

    (apply . ,(lambda (f . args) (apply (if (func? f) (func-fn f) f)
                                        (if (pair? (cdr args))
                                            (append (butlast args)
                                                    (->list (mal-value (last args))))
                                            (->list (mal-value (car args)))))))
    (map . ,(lambda (f items) (mal-list (map-in-order
                                         (if (func? f) (func-fn f) f)
                                         (->list (mal-value items))))))

    (nil? . ,(lambda (x) (coerce (eq? x mal-nil))))
    (true? . ,(lambda (x) (coerce (eq? x mal-true))))
    (false? . ,(lambda (x) (coerce (eq? x mal-false))))
    (number? . ,(lambda (x) (coerce (mal-instance-of? x 'number))))
    (string? . ,(lambda (x) (coerce (mal-instance-of? x 'string))))
    (symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol))))
    (symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x)))))
    (keyword? . ,(lambda (x) (coerce (mal-instance-of? x 'keyword))))
    (keyword . ,(lambda (x) (mal-keyword (string->symbol (mal-value x)))))
    (vector? . ,(lambda (x) (coerce (mal-instance-of? x 'vector))))
    (vector . ,(lambda args (mal-vector (list->vector args))))
    (map? . ,(lambda (x) (coerce (mal-instance-of? x 'map))))
    (hash-map . ,(lambda args (mal-map (list->alist args))))
    (sequential? . ,(lambda (x) (coerce (and (mal-object? x)
                                             (memq (mal-type x)
                                                   '(list vector))))))
    (fn? . ,(lambda (x) (coerce (or (procedure? x)
                                    (and (func? x) (not (func-macro? x)))))))
    (macro? . ,(lambda (x) (coerce (and (func? x) (func-macro? x)))))

    (assoc . ,(lambda (m . kvs) (mal-map (mal-map-assoc (mal-value m) kvs))))
    (dissoc . ,(lambda (m . keys) (mal-map (mal-map-dissoc (mal-value m) keys))))
    (get . ,(lambda (m key) (mal-map-ref key (mal-value m) mal-nil)))
    (contains? . ,(lambda (m key) (coerce (mal-map-ref key (mal-value m)))))
    (keys . ,(lambda (m) (mal-list (map car (mal-value m)))))
    (vals . ,(lambda (m) (mal-list (map cdr (mal-value m)))))

    (with-meta . ,(lambda (x meta)
                    (cond
                     ((mal-object? x)
                      (make-mal-object (mal-type x) (mal-value x) meta))
                     ((func? x)
                      (let ((func (make-func (func-ast x) (func-params x)
                                             (func-env x) (func-fn x))))
                        (func-macro?-set! func (func-macro? x))
                        (func-meta-set! func meta)
                        func))
                     (else
                      (error "unsupported type")))))
    (meta . ,(lambda (x) (cond
                          ((mal-object? x)
                           (or (mal-meta x) mal-nil))
                          ((func? x)
                           (or (func-meta x) mal-nil))
                          (else
                           mal-nil))))

    ))

)

)
Commit	Line	Data
1d20dc6b VS	1	(define-library (lib core)
	2
	3	(export ns)
	4
	5	(import (scheme base))
	6	(import (scheme write))
663059ad	7	(import (scheme file))
8e53f705	8	(import (scheme time))
a43528b9 VS	9	(import (scheme read))
a43528b9 VS	10	(import (scheme eval))
49352c89 VS	11	;; HACK: cyclone doesn't implement environments yet, but its eval
	12	;; behaves as if you were using the repl environment
	13	(cond-expand
	14	(cyclone)
	15	(else
	16	(import (scheme repl))))
1d20dc6b VS	17
	18	(import (lib types))
	19	(import (lib util))
	20	(import (lib printer))
663059ad	21	(import (lib reader))
1d20dc6b VS	22
	23	(begin
	24
	25	(define (coerce x)
	26	(if x mal-true mal-false))
	27
	28	(define (->printed-string args print-readably sep)
	29	(let ((items (map (lambda (arg) (pr-str arg print-readably)) args)))
	30	(string-intersperse items sep)))
	31
	32	(define (mal-equal? a b)
	33	(let ((a-type (and (mal-object? a) (mal-type a)))
	34	(a-value (and (mal-object? a) (mal-value a)))
	35	(b-type (and (mal-object? b) (mal-type b)))
	36	(b-value (and (mal-object? b) (mal-value b))))
	37	(cond
	38	((or (not a-type) (not b-type))
	39	mal-false)
	40	((and (memq a-type '(list vector))
	41	(memq b-type '(list vector)))
	42	(mal-list-equal? (->list a-value) (->list b-value)))
	43	((and (eq? a-type 'map) (eq? b-type 'map))
1d117aaf	44	(mal-map-equal? a-value b-value))
1d20dc6b VS	45	(else
	46	(and (eq? a-type b-type)
	47	(equal? a-value b-value))))))
	48
	49	(define (mal-list-equal? as bs)
	50	(let loop ((as as)
	51	(bs bs))
	52	(cond
	53	((and (null? as) (null? bs)) #t)
	54	((or (null? as) (null? bs)) #f)
	55	(else
	56	(if (mal-equal? (car as) (car bs))
	57	(loop (cdr as) (cdr bs))
	58	#f)))))
	59
1d117aaf VS	60	(define (mal-map-ref key m . default)
	61	(if (pair? default)
	62	(alist-ref key m mal-equal? (car default))
	63	(alist-ref key m mal-equal?)))
	64
	65	(define (mal-map-equal? as bs)
	66	(if (not (= (length as) (length bs)))
	67	#f
	68	(let loop ((as as))
	69	(if (pair? as)
	70	(let* ((item (car as))
	71	(key (car item))
	72	(value (cdr item)))
	73	(if (mal-equal? (mal-map-ref key bs) value)
	74	(loop (cdr as))
	75	#f))
	76	#t))))
	77
	78	(define (mal-map-dissoc m keys)
	79	(let loop ((items m)
	80	(acc '()))
	81	(if (pair? items)
	82	(let* ((item (car items))
	83	(key (car item)))
	84	(if (contains? keys (lambda (x) (mal-equal? key x)))
	85	(loop (cdr items) acc)
	86	(loop (cdr items) (cons item acc))))
	87	(reverse acc))))
	88
	89	(define (mal-map-assoc m kvs)
	90	(let ((kvs (list->alist kvs)))
	91	(append kvs (mal-map-dissoc m (map car kvs)))))
	92
05414421 VS	93	(define (map-in-order proc items)
	94	(let loop ((items items)
	95	(acc '()))
	96	(if (null? items)
	97	(reverse acc)
	98	(loop (cdr items) (cons (proc (car items)) acc)))))
	99
663059ad VS	100	(define (slurp path)
	101	(call-with-output-string
	102	(lambda (out)
	103	(call-with-input-file path
	104	(lambda (in)
	105	(let loop ()
	106	(let ((chunk (read-string 1024 in)))
	107	(when (not (eof-object? chunk))
	108	(display chunk out)
	109	(loop)))))))))
	110
8e53f705 VS	111	(define (time-ms)
	112	(* (/ (current-jiffy) (jiffies-per-second)) 1000.0))
	113
a43528b9 VS	114	(define (->mal-object x)
	115	(cond
	116	((boolean? x) (if x mal-true mal-false))
	117	((char? x) (mal-string (char->string x)))
	118	((procedure? x) x)
	119	((symbol? x) (mal-symbol x))
	120	((number? x) (mal-number x))
	121	((string? x) (mal-string x))
	122	((or (null? x) (pair? x))
	123	(mal-list (map ->mal-object x)))
	124	((vector? x)
	125	(mal-vector (vector-map ->mal-object x)))
	126	(else
	127	(error "unknown type"))))
	128
	129	(define (scm-eval input)
	130	(call-with-input-string input
	131	(lambda (port)
49352c89 VS	132	(cond-expand
	133	(cyclone
	134	(->mal-object (eval (read port))))
	135	(else
2b9b1104 VS	136	(->mal-object (eval (read port) (environment '(scheme base)
2b9b1104 VS	137	'(scheme write)))))))))
a43528b9	138
1d20dc6b VS	139	(define ns
	140	`((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
	141	(- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
	142	(* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
	143	(/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))
	144
	145	(list . ,(lambda args (mal-list args)))
663059ad	146	(list? . ,(lambda (x) (coerce (mal-instance-of? x 'list))))
1d20dc6b VS	147	(empty? . ,(lambda (lis) (coerce (null? (->list (mal-value lis))))))
	148	(count . ,(lambda (lis) (mal-number
	149	(if (eq? lis mal-nil)
	150	0
	151	(length (->list (mal-value lis)))))))
	152
	153	(< . ,(lambda (a b) (coerce (< (mal-value a) (mal-value b)))))
	154	(<= . ,(lambda (a b) (coerce (<= (mal-value a) (mal-value b)))))
	155	(> . ,(lambda (a b) (coerce (> (mal-value a) (mal-value b)))))
	156	(>= . ,(lambda (a b) (coerce (>= (mal-value a) (mal-value b)))))
	157	(= . ,(lambda (a b) (coerce (mal-equal? a b))))
	158
	159	(pr-str . ,(lambda args (mal-string (->printed-string args #t " "))))
	160	(str . ,(lambda args (mal-string (->printed-string args #f ""))))
	161	(prn . ,(lambda args
	162	(display (->printed-string args #t " "))
	163	(newline)
	164	mal-nil))
	165	(println . ,(lambda args
	166	(display (->printed-string args #f " "))
	167	(newline)
	168	mal-nil))
	169
663059ad VS	170	(read-string . ,(lambda (string) (read-str (mal-value string))))
663059ad VS	171	(slurp . ,(lambda (path) (mal-string (slurp (mal-value path)))))
1d117aaf	172	(throw . ,(lambda (x) (raise (cons 'user-error x))))
8e53f705 VS	173	(readline . ,(lambda (prompt) (let ((output (readline (mal-value prompt))))
	174	(if output (mal-string output) mal-nil))))
	175	(time-ms . ,(lambda () (mal-number (time-ms))))
a43528b9	176	(scm-eval . ,(lambda (input) (scm-eval (mal-value input))))
663059ad VS	177
	178	(atom . ,(lambda (x) (mal-atom x)))
	179	(atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom))))
	180	(deref . ,(lambda (atom) (mal-value atom)))
	181	(reset! . ,(lambda (atom x) (mal-value-set! atom x) x))
	182	(swap! . ,(lambda (atom fn . args)
	183	(let* ((fn (if (func? fn) (func-fn fn) fn))
	184	(value (apply fn (cons (mal-value atom) args))))
	185	(mal-value-set! atom value)
	186	value)))
	187
7f0ce0f0 VS	188	(cons . ,(lambda (x xs) (mal-list (cons x (->list (mal-value xs))))))
7f0ce0f0 VS	189	(concat . ,(lambda args (mal-list (apply append (map (lambda (arg) (->list (mal-value arg))) args)))))
0d6f8696 VS	190	(nth . ,(lambda (x n) (let ((items (->list (mal-value x)))
	191	(index (mal-value n)))
	192	(if (< index (length items))
	193	(list-ref items index)
	194	(error (str "Out of range: " index))))))
	195	(first . ,(lambda (x) (if (eq? x mal-nil)
	196	mal-nil
	197	(let ((items (->list (mal-value x))))
	198	(if (null? items)
	199	mal-nil
	200	(car items))))))
	201	(rest . ,(lambda (x) (if (eq? x mal-nil)
	202	(mal-list '())
	203	(let ((items (->list (mal-value x))))
	204	(if (null? items)
	205	(mal-list '())
	206	(mal-list (cdr items)))))))
8e53f705 VS	207	(conj . ,(lambda (coll . args)
	208	(let ((items (mal-value coll)))
	209	(cond
	210	((vector? items)
	211	(mal-vector (vector-append items (list->vector args))))
	212	((list? items)
	213	(mal-list (append (reverse args) items)))
	214	(else
	215	(error "invalid collection type"))))))
	216	(seq . ,(lambda (x) (if (eq? x mal-nil)
	217	mal-nil
	218	(let ((value (mal-value x)))
	219	(case (mal-type x)
	220	((list)
	221	(if (null? value)
	222	mal-nil
	223	x))
	224	((vector)
	225	(if (zero? (vector-length value))
	226	mal-nil
	227	(mal-list (vector->list value))))
	228	((string)
	229	(if (zero? (string-length value))
	230	mal-nil
	231	(mal-list (map mal-string (explode value)))))
	232	(else
	233	(error "invalid collection type")))))))
7f0ce0f0	234
1d117aaf VS	235	(apply . ,(lambda (f . args) (apply (if (func? f) (func-fn f) f)
	236	(if (pair? (cdr args))
	237	(append (butlast args)
	238	(->list (mal-value (last args))))
	239	(->list (mal-value (car args)))))))
05414421 VS	240	(map . ,(lambda (f items) (mal-list (map-in-order
	241	(if (func? f) (func-fn f) f)
	242	(->list (mal-value items))))))
1d117aaf VS	243
	244	(nil? . ,(lambda (x) (coerce (eq? x mal-nil))))
	245	(true? . ,(lambda (x) (coerce (eq? x mal-true))))
	246	(false? . ,(lambda (x) (coerce (eq? x mal-false))))
7cabea4f	247	(number? . ,(lambda (x) (coerce (mal-instance-of? x 'number))))
8e53f705	248	(string? . ,(lambda (x) (coerce (mal-instance-of? x 'string))))
1d117aaf VS	249	(symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol))))
	250	(symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x)))))
	251	(keyword? . ,(lambda (x) (coerce (mal-instance-of? x 'keyword))))
	252	(keyword . ,(lambda (x) (mal-keyword (string->symbol (mal-value x)))))
	253	(vector? . ,(lambda (x) (coerce (mal-instance-of? x 'vector))))
	254	(vector . ,(lambda args (mal-vector (list->vector args))))
	255	(map? . ,(lambda (x) (coerce (mal-instance-of? x 'map))))
	256	(hash-map . ,(lambda args (mal-map (list->alist args))))
	257	(sequential? . ,(lambda (x) (coerce (and (mal-object? x)
	258	(memq (mal-type x)
	259	'(list vector))))))
7cabea4f VS	260	(fn? . ,(lambda (x) (coerce (or (procedure? x)
	261	(and (func? x) (not (func-macro? x)))))))
	262	(macro? . ,(lambda (x) (coerce (and (func? x) (func-macro? x)))))
1d117aaf VS	263
	264	(assoc . ,(lambda (m . kvs) (mal-map (mal-map-assoc (mal-value m) kvs))))
	265	(dissoc . ,(lambda (m . keys) (mal-map (mal-map-dissoc (mal-value m) keys))))
	266	(get . ,(lambda (m key) (mal-map-ref key (mal-value m) mal-nil)))
	267	(contains? . ,(lambda (m key) (coerce (mal-map-ref key (mal-value m)))))
	268	(keys . ,(lambda (m) (mal-list (map car (mal-value m)))))
	269	(vals . ,(lambda (m) (mal-list (map cdr (mal-value m)))))
	270
8e53f705 VS	271	(with-meta . ,(lambda (x meta)
	272	(cond
	273	((mal-object? x)
	274	(make-mal-object (mal-type x) (mal-value x) meta))
	275	((func? x)
	276	(let ((func (make-func (func-ast x) (func-params x)
	277	(func-env x) (func-fn x))))
	278	(func-macro?-set! func (func-macro? x))
	279	(func-meta-set! func meta)
	280	func))
	281	(else
	282	(error "unsupported type")))))
	283	(meta . ,(lambda (x) (cond
	284	((mal-object? x)
	285	(or (mal-meta x) mal-nil))
	286	((func? x)
	287	(or (func-meta x) mal-nil))
	288	(else
	289	mal-nil))))
	290
1d20dc6b VS	291	))
	292
	293	)
	294
	295	)