test-backup.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! 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 (t (lambda (@2 val s1) (apply c
        (list t (fun (var) var) val)
        (eval @2 s1)))))))))

(run (define string-> (id-type-converter string)))
(run (define int-> (id-type-converter int)))
(run (define pexp-> (id-type-converter pexp)))

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

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

(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 val s9) (do
    (define var (gen-var name))
    (define t' (fst val))
    (define meta' (snd val))
    (define val' (trd val))
    (apply prepend! t' (fun (s' c') (do
        (parse-str name s' (fun (_ s'1) (do
        (log-parser (cat "'" name) s'1)
        (apply c' (meta' (quote var)) s'1)))))))
    (apply c
        (. set! var val')
        (eval @1 s9))))))))))))))))))))))))))

(run (prepend! top let-parser))

(run (define typed-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
    ((fun (c') (if (and (not (empty-str s4)) (= (str-head s4) ":"))
        (do
            (log-parser ":" (str-tail s4))
            (parse-ws' (str-tail s4) (fun (_ s')
            (parse s' (bexp-type c')))))
        (apply c' (list) s4))) (lambda (@1 t s5) (do
    (parse-ws' (eval @1 s5) (fun (_ s6) (do
    (parse-str "=" s6 (fun (_ s7) (do
    (log-parser "=" s7)
    (parse-ws s7 (fun (_ s8)
    (parse s8 ((if t (fst t) bexp) (lambda (@2 val s9)
    ((fun (var) (do
        (define t' (if t (snd t) (fst val)))
        (define val' (if t val (snd val)))
        (apply prepend! t' (fun (s' c') (do
            (parse-str name s' (fun (_ s'1) (do
            (log-parser (cat "'" name) s'1)
            (apply c' var s'1)))))))
        (apply c (. set! var val') (eval @2 s9))))
    (gen-var name)))))))))))))))))))))))))))))))

(run (prepend! top typed-let-parser))

let x: pexp = 3
let y = (+ x 2)
(print y)