test.soup

(run (set! pexp (cons
    ((fun (var m)
        (fun (s c)
            (if (starts-with s m)
                (do
                    (log-parser "'parse-str" s)
                    (apply c var (drop (length m) s)))
                (list))))
        (gen-var "parse-str") "parse-str")
    pexp)))

(run (def! (list) parse-str (fun (m s c)
    (if (starts-with s m)
        (apply c m (drop (length m) s))
        (list)))))

(run (set! pexp (cons
    ((fun (var) (fun (s c)
        (parse-str "define-var" s (fun (_ s1) (do
            (log-parser "'define-var" s1)
            (apply c var s1))))))
        (gen-var "define-var"))
    pexp)))

(run (def! (list) define-var (fun (name val) ((fun (var) (do
        (set! pexp (cons
            (fun (s c)
                (parse-str name s (fun (_ s1) (do
                        (log-parser (cat "'" name) s1)
                        (apply c var s1)))))
            pexp))
        (apply def! (list) var val)))
        (gen-var name)))))

(run (define-var "prepend!" (lambda (@1 l x) ((fun (l' x')
        (apply set! l (cons x' l')))
    (eval @1 l)
    (eval @1 x)))))

(run (define-var "parse-while" (fun (pred s c) ((fun (l)
    (if (empty-str (head l))
        (list)
        (apply c (head l) (head (tail l)))))
    (span pred s)))))

(run (define-var "parse-ws" (fun (s c)
    (parse-while
        (fun (x) (elem (list " " "\n" "\t") x))
        s
        (fun (v s1) (apply c v s1))))))

(run (define-var "parse-ident" (fun (s c)
    (parse-while
        (fun (x) (or
            (is-alpha-num x)
            (elem (str->list "~!@#$%^&*-=+_|'<>?") x)))
        s
        (fun (name s1)
            (if (all (map is-digit (str->list name)))
                (list)
                (apply c name s1)))))))

(run (prepend! pexp (fun (s c)
    (parse-str "(define" s (fun (_ s1) (do
    (log-parser "(define" s1)
    (parse-ws s1 (fun (_ s2) (do
    (parse-ident s2 (fun (name s3)
    ((fun (var)
        (do
            (prepend! pexp (fun (s' c') (do
                (parse-str name s' (fun (_ s'1) (do
                (log-parser (cat "'" name) s'1)
                (apply c' var s'1)))))))
            (log-parser name s3)
            (parse-ws s3 (fun (_ s4)
            (parse s4 (pexp (lambda (@1 val s5)
            (parse-str ")" (eval @1 s5) (fun (_ s6) (do
                (log-parser ")" s6)
                (apply c (. set! (list var val)) s6)))))))))))
        (gen-var name)))))))))))))

(run (define true 1))
(run (define false (list)))
(run (define otherwise true))
(run (define fst (fun (l) (head l))))
(run (define snd (fun (l) (head (tail l)))))
(run (define trd (fun (l) (head (tail (tail l))))))
(run (define str-head (fun (s) (head (str->list s)))))
(run (define str-tail (fun (s) (list->str (tail (str->list s))))))

(run (define parse-while' (fun (pred s c) (do
    (define l (span pred s))
    (apply c (fst l) (snd l))))))

(run (define parse-ws' (fun (s c) (parse-while'
    (fun (x) (elem (list " " "\n" "\t") x))
    s c))))

(run (define int-parser (fun (s c)
    (parse-while is-digit s (fun (digits s1) (do
        (log-parser digits s1)
        (apply c (read-int digits) s1)))))))

(run (define int (list int-parser)))

(run (define char->code (fun (char) (cond
    ((= char "b") "\b")
    ((= char "n") "\n")
    ((= char "f") "\f")
    ((= char "r") "\r")
    ((= char "t") "\t")
    ((= char "\\") "\\")
    ((= char "\"") "\"")
    (otherwise char)))))

(run (define take-string (list)))

(run (define take-string-rec (fun (m s) (do
    (define rest (take-string s))
    (if rest
        (list
            (cat m (fst rest))
            (snd rest))
        (list))))))

(run (set! take-string (fun (s) (cond
    ((empty-str s) (list))
    ((= (str-head s) "\"") (list "" s))
    ((= (str-head s) "\\") (if (empty-str (str-tail s)) (list)
        (take-string-rec
            (char->code (snd s))
            (drop 2 s))
    (otherwise (take-string-rec
        (str-head s)
        (str-tail s)))))))))

(run (define string-parser (fun (s c)
    (parse-str "\"" s (fun (_ s1) (do
    (log-parser "\"" s1)
    (define t (take-string s1))
    (cond
        ((not t) (list))
        ((empty-str (fst t)) (list))
        (otherwise (do
            (define m (fst t))
            (define s' (snd t))
            (parse-str "\"" (fun (_ s2) (do
                (log-parser (show m) s2)
                (apply c m s2)))))))))))))

(run (define string (list string-parser)))

(run (define literal-parser (fun (name val) (fun (s c)
    (parse-str name s (fun (_ s1) (do
        (log-parser (cat "'" name) s1)
        (apply c val s1))))))))

(run (define id-type-converter (lambda (@1 t) (fun (s c)
    (parse s ((eval @1 t) (lambda (@2 val s1) (apply c
        (list t (fun (var) var) val)
        (eval @2 s1)))))))))

(run (define void (list)))

(run (define string->bexp (id-type-converter string)))
(run (define int->bexp (id-type-converter int)))
(run (define void->bexp (id-type-converter void)))

(run (define bexp (list int->bexp string->bexp void->bexp)))

(run (define let-parser (fun (s c)
    (parse-str "let" s (fun (_ s1) (do
    (log-parser "let" s1)
    (parse-ws s1 (fun (_ s2) (do
    (parse-ident s2 (fun (name s3) (do
    (log-parser name s3)
    (parse-ws' s3 (fun (_ s4) (do
    (parse-str "=" s4 (fun (_ s5) (do
    (log-parser "=" s5)
    (parse-ws s5 (fun (_ s6)
    (parse s6 (bexp (lambda (@1 bexp-desc s9) (do
        (define var (gen-var name))
        (define t (fst bexp-desc))
        (define meta (snd bexp-desc))
        (define val (trd bexp-desc))
        (apply prepend! t (fun (s' c') (do
            (parse-str name s' (fun (_ s'1) (do
            (log-parser (cat "'" name) s'1)
            (apply c' (meta var) s'1)))))))
        (apply c
            (. set! (list var val))
            (eval @1 s9))))))))))))))))))))))))))

(run (prepend! top let-parser))

(run (define bexp->top (fun (s c)
    (parse s (bexp (fun (bexp-desc s1)
    (apply c (trd bexp-desc) s1)))))))

(run (prepend! top bexp->top))

(run (define function (list
    (literal-parser "puts" (list (quote (list string)) (quote void) (quote puts)))
    (literal-parser "print" (list (quote (list int)) (quote string) (quote print)))
    (literal-parser "print" (list (quote (list string)) (quote string) (quote print)))
    (literal-parser "print" (list (quote (list pexp)) (quote string) (quote print)))
    (literal-parser "print" (list (quote (list void)) (quote string) (quote print)))
    (literal-parser "plus" (list (quote (list int int)) (quote int) (quote +))))))

(run (define parse-args (fun (params s c)
    (if params
        (parse s ((head params) (lambda (@1 arg s1)
            (if (tail params) (do
                    (parse-str "," (eval @1 s1) (fun (_ s2) (do
                    (log-parser "," s2)
                    (parse-ws s2 (fun (_ s3)
                    (parse-args (tail params) s3 (lambda (@2 args s4)
                    (apply c (cons arg args) (eval @2 s4))))))))))
                (apply c (list arg) (eval @1 s1))))))
        (c (list) s)))))

(run (define call-parser (lambda (@1 t) (fun (s c)
    (parse s (function (fun (fun-desc s1)
    (parse-str "(" s1 (fun (_ s2) (do
    (log-parser "(" s2)
    (define params (eval @1 (fst fun-desc)))
    (define ret-type (snd fun-desc))
    (define f (trd fun-desc))
    (if (!= ret-type t) (list) (do
        (parse-args params s2 (lambda (@2 args s3)
        (parse-str ")" (eval @2 s3) (fun (_ s4) (do
        (log-parser ")" s4)
        (apply c (. f args) s4))))))))))))))))))

(run (prepend! int (call-parser int)))
(run (prepend! string (call-parser string)))
(run (prepend! void (call-parser void)))

(run (define bexp-type (list
    (literal-parser "int" (list int (quote int)))
    (literal-parser "string" (list string (quote string)))
    (literal-parser "void" (list void (quote void))))))

(run (define function->bexp (fun (s c)
    (parse s (function (fun (fun-desc s1) (do
    (define params (fst fun-desc))
    (define ret-type (snd fun-desc))
    (define f (trd fun-desc))
    (define fun-bexp (list
        (quote function)
        (fun (var) (list params ret-type var))
        f))
    (apply c fun-bexp s1))))))))

(run (prepend! bexp function->bexp))

let x = 3
let y = plus(x, 2)
print(y)
let + = plus
print(+(y, 5))