((provide language:empty language:initial language:primitive
          language:base-primitive language:base
          module:base-primitive module:base)
 (require ast:var ast:prim ast:lambda ast:let ast:list
          primitive-op-descriptions primitive-op-type-signature
          parse env:empty env:initial env:primitive language module))

(define language:empty     (language '() '() '() '() env:empty))
(define language:initial   (language '() '() '() '() env:initial))
(define language:primitive (language '() '() '() '() env:primitive))

(define names:prim (cons 'apply (map car primitive-op-descriptions)))
(define language:base-primitive
  (language names:prim '() names:prim '() env:initial))
(define module:base-primitive
  (let* ((lam:apply (parse env:primitive
                           '(lambda (f arg . args)
                              (define (cons* x xs)
                                (if (null? xs) x
                                  (cons x (cons* (car xs) (cdr xs)))))
                              (apply f (cons* arg args)))))
         (lams:prim
           (map (lambda (po-desc)
                  (define (x i) (vector-ref '#(x0 x1 x2 x3 x4) i))
                  (define type-sig (primitive-op-type-signature po-desc))
                  (define p* (map x (range (length (car type-sig)))))
                  (ast:lambda p* (ast:prim (car po-desc) (map ast:var p*))))
                primitive-op-descriptions))
         (ast (ast:lambda
                '() (ast:let names:prim (cons lam:apply lams:prim)
                             (apply ast:list (map ast:var names:prim))))))
    (module '() names:prim ast '() '())))

(define defs:base
  '((error (lambda args ('error args)))
    (not (lambda (b) (if b #f #t)))
    (caar  (lambda (v) (car (car v))))
    (cadr  (lambda (v) (car (cdr v))))
    (cddr  (lambda (v) (cdr (cdr v))))
    (cdar  (lambda (v) (cdr (car v))))
    (caaar (lambda (v) (car (caar v))))
    (caadr (lambda (v) (car (cadr v))))
    (cadar (lambda (v) (car (cdar v))))
    (caddr (lambda (v) (car (cddr v))))
    (cdaar (lambda (v) (cdr (caar v))))
    (cdadr (lambda (v) (cdr (cadr v))))
    (cddar (lambda (v) (cdr (cdar v))))
    (cdddr (lambda (v) (cdr (cddr v))))
    (list-tail (lambda (xs i) (if (= 0 i) xs (list-tail (cdr xs) (- i 1)))))
    (list-ref  (lambda (xs i) (car (list-tail xs i))))
    (list->vector (lambda (xs)
                    (define result (make-mvector (length xs) #t))
                    (foldl (lambda (x i) (mvector-set! result i x) (+ i 1))
                           0 xs)
                    (mvector->vector result)))
    (vector->list (lambda (v)
                    (let loop ((i (- (vector-length v) 1)) (xs '()))
                      (if (< i 0) xs
                        (loop (- i 1) (cons (vector-ref v i) xs))))))
    (string->list (lambda (s) (vector->list (string->vector s))))
    (list->string (lambda (cs) (vector->string (list->vector cs))))
    (equal? (lambda (a b)
              (cond ((pair? a)   (and (pair? b) (equal? (car a) (car b))
                                      (equal? (cdr a) (cdr b))))
                    ((vector? a) (and (vector? b) (equal? (vector->list a)
                                                          (vector->list b))))
                    ((boolean? a)   (and (boolean? b)   (boolean=? a b)))
                    ((string?  a)   (and (string?  b)   (string=?  a b)))
                    ((number?  a)   (and (number?  b)   (number=?  a b)))
                    ((mvector? a)   (and (mvector? b)   (mvector=? a b)))
                    ((procedure? a) (and (procedure? b) (procedure=? a b)))
                    ((null? a)      (null? b)))))
    (vector (lambda xs (list->vector xs)))
    (vector-set (lambda (v i x)
                  (define result (make-mvector (vector-length v) #t))
                  (foldl (lambda (x i) (mvector-set! result i x) (+ i 1))
                         0 (vector->list v))
                  (mvector-set! result i x)
                  (mvector->vector result)))
    (list?  (lambda (v) (or (and (pair? v) (list? (cdr v))) (null? v))))
    (list   (lambda xs xs))
    (list*  (lambda (x . xs) (if (null? xs) x (cons x (apply list* xs)))))
    ;; TODO: n-ary versions of foldl, foldr.
    (foldl  (lambda (f acc xs) (if (null? xs) acc
                                 (foldl f (f (car xs) acc) (cdr xs)))))
    (foldr  (lambda (f acc xs) (if (null? xs) acc
                                 (f (car xs) (foldr f acc (cdr xs))))))
    (map (lambda (f xs . xss)
           (define (map1 f xs) (if (null? xs) '()
                                 (cons (f (car xs)) (map1 f (cdr xs)))))
           (cond ((null? xs) '())
                 (#t (cons (apply f (car xs) (map1 car xss))
                           (apply map f (cdr xs) (map1 cdr xss)))))))
    (for-each (lambda args (apply map args) #t))
    (andmap (lambda (f xs . xss)
              (let loop ((last #t) (xs xs) (xss xss))
                (and last (if (null? xs) last
                            (loop (apply f (car xs) (map car xss))
                                  (cdr xs) (map cdr xss)))))))
    (ormap (lambda (f xs . xss)
             (cond ((null? xs) #f)
                   (#t (let ((? (apply f (car xs) (map car xss))))
                         (if ? ? (apply ormap f (cdr xs) (map cdr xss))))))))
    (filter (lambda (p? xs)
              (cond ((null? xs) '())
                    ((p? (car xs)) (cons (car xs) (filter p? (cdr xs))))
                    (#t (filter p? (cdr xs))))))
    (filter-not (lambda (p? xs) (filter (lambda (x) (not (p? x))) xs)))
    (remf (lambda (p? xs)
            (cond ((null? xs)    '())
                  ((p? (car xs)) (cdr xs))
                  (#t (cons (car xs) (remf p? (cdr xs)))))))
    (remove (lambda (v xs) (remf (lambda (x) (equal? x v)) xs)))
    (length (lambda (xs) (foldl (lambda (_ l) (+ 1 l)) 0 xs)))
    (append (lambda xss (foldr (lambda (xs yss) (foldr cons yss xs)) '() xss)))
    (reverse-append (lambda (xs ys) (foldl cons ys xs)))
    (reverse (lambda (xs) (reverse-append xs '())))
    (range (lambda (n)
             (let loop ((i 0)) (if (= i n) '() (cons i (loop (+ i 1)))))))
    (split (lambda (xs n)
             (let loop ((xs xs) (n n) (rprefix '()))
               (if (= 0 n) (cons rprefix xs)
                 (loop (cdr xs) (- n 1) (cons (car xs) rprefix))))))
    (take  (lambda (xs n) (reverse (car (split xs n)))))
    (drop  (lambda (xs n) (cdr (split xs n))))
    (memf (lambda (? xs) (cond ((null? xs) #f)
                               ((? (car xs)) xs)
                               (#t (memf ? (cdr xs))))))
    (member (lambda (v xs) (memf (lambda (x) (equal? x v)) xs)))
    (assoc (lambda (k xs) (cond ((null? xs) #f)
                                ((equal? k (caar xs)) (car xs))
                                (#t (assoc k (cdr xs))))))
    (alist-get (lambda (rs key default) (let ((rib (assoc key rs)))
                                          (if rib (cdr rib) default))))
    (alist-ref (lambda (alist k)
                 (cdr (or (assoc k alist)
                          (error '"alist-ref of non-existent key:" k alist)))))
    (alist-ref* (lambda (alist k*) (map (lambda (k) (alist-ref alist k)) k*)))
    (alist-remove* (lambda (rs keys)
                     (filter (lambda (rib) (not (member (car rib) keys))) rs)))
    (string-append (lambda ss
                     (define css (map vector->list (map string->vector ss)))
                     (vector->string (list->vector (apply append css)))))
    (string-split
      (lambda (str sep)
        (define (rseg->str s) (list->string (reverse s)))
        (define sepv  (string->vector sep))
        (define sepcs (vector->list sepv))
        (define len   (vector-length sepv))
        (define v     (string->vector str))
        (let loop ((cs (vector->list v))
                   (clen (vector-length v)) (rseg '()) (rs '()))
          (cond ((null? cs)   (map rseg->str (reverse (if (pair? rseg)
                                                        (cons rseg rs) rs))))
                ((< clen len) (loop '() 0 (append cs rseg) rs))
                ((equal? (take cs len) sepcs)
                 (loop (drop cs len) (- clen len) '() (cons rseg rs)))
                (#t (loop (cdr cs) (- clen 1) (cons (car cs) rseg) rs))))))
    (string-join
      (lambda (strs sep)
        (let ((rstrs (reverse strs)) (sepcs (string->list sep)))
          (list->string
            (foldl (lambda (s cs) (append (string->list s) (append sepcs cs)))
                   (string->list (car rstrs)) (cdr rstrs))))))
    ))

(define names:base      (map car defs:base))
(define names:prim&base (append names:prim names:base))
(define language:base
  (language names:prim&base '() names:prim&base '() env:initial))
(define module:base
  (let ((ast (parse env:initial
                    (list 'lambda names:prim
                          (list 'letrec defs:base
                                (cons '(lambda xs xs) names:base))))))
    (module names:prim names:base ast '() '())))
