path: root/tests/lispparser.lisp

#include "stdlib.lisp"

; string -> string
(define string-escape (str)
    (let ((hexdigit (lambda (n) (substr n 1 "0123456789abcdef")))
          (go (lambdarec rec (str yet)
                    (if (= str "") yet
                        (let ((ch (substr 0 1 str))
                              (n (ord ch))
                              (out (cond
                                        (= ch "\n") "\\n"
                                        (= ch "\r") "\\r"
                                        (= ch "\t") "\\t"
                                        (= ch "\0") "\\0"
                                        (= ch "\"") "\\\""
                                        (= ch "\\") "\\\\"
                                        (< n 32) (concat "\\x" (hexdigit (/ n 16)) (hexdigit (mod n 16)))
                                        ch)))
                            (rec (substr 1 -1 str) (concat yet out)))))))
        (go str "")))

; tag string -> string
(define ansi-color (clr str)
    (let ((style (cond
                    (= clr 'red) "31"
                    (= clr 'green) "32"
                    (= clr 'yellow) "33"
                    (= clr 'blue) "34"
                    (= clr 'cyan) "36"
                    (error "Unknown color in ansi-color" clr))))
        (concat "\x1B[" style "m" str "\x1B[0m")))

; char string -> bool
(define str-elem (ch str)
    (if (= str "") 0
        (if (= ch (substr 0 1 str)) 1
            (str-elem ch (substr 1 -1 str)))))

; char -> bool
(define isspace? (ch)
    (str-elem ch " \n\t\r"))

; char -> bool
(define isdigit? (ch)
    (let ((n (ord ch))) (and (<= 48 n) (<= n 57))))

; char -> bool
(define lowercase? (ch)
    (let ((n (ord ch))) (and (<= 97 n) (<= n 122))))

; char -> bool
(define uppercase? (ch)
    (let ((n (ord ch))) (and (<= 65 n) (<= n 90))))

; char -> bool
(define iswordchar? (ch)
    (or (str-elem ch "-_?+/*!=<>.")
        (or (lowercase? ch) (uppercase? ch))))

; char -> bool
(define isrestwordchar? (ch)
    (or (iswordchar? ch) (isdigit? ch)))

; string -> int  (does not perform any checking)
(define parse-int (str)
    (let ((helper (lambdarec rec (str n)
                        (let ((ch (substr 0 1 str))
                              (rest (substr 1 -1 str)))
                            (if (isdigit? ch)
                                (rec rest (+ (* 10 n) (- (ord ch) 48)))
                                n)))))
        (helper str 0)))

; char -> int
(define parse-hex-digit (ch)
    (let ((n (ord ch)))
        (cond
            (and (<= 48 n) (<= n 57))
                (- n 48)
            (and (<= 97 n) (<= n 102))
                (- n 87)
            (and (<= 65 n) (<= n 70))
                (- n 55)
            (error "Invalid hex escape digit " ch))))

; string -> (string[parsed escape] string[rest])
(define parse-string-escape (str)
    (let ((ch (substr 0 1 str)))
        (cond
            (= ch "n")
                (list "\n" (substr 1 -1 str))
            (= ch "r")
                (list "\r" (substr 1 -1 str))
            (= ch "t")
                (list "\t" (substr 1 -1 str))
            (= ch "0")
                (list "\0" (substr 1 -1 str))
            (= ch "\"")
                (list "\"" (substr 1 -1 str))
            (= ch "\\")
                (list "\\" (substr 1 -1 str))
            (= ch "x")
                (let ((h1 (parse-hex-digit (substr 1 1 str)))
                      (h2 (parse-hex-digit (substr 2 1 str))))
                    (list (chr (+ (* 16 h1) h2)) (substr 3 -1 str)))
            (error "Invalid string escape character " ch))))

; string[input] string[string to prepend to result] -> (string[parsed till bare "] string[rest])
(define parse-string-contents (str yet)
    (let ((ch (substr 0 1 str))
          (rest (substr 1 -1 str)))
        (cond
            (= ch "")
                (error "Non-terminated string in source")
            (= ch "\"")
                (list yet rest)
            (= ch "\\")
                (let ((pair (parse-string-escape rest)))
                    (parse-string-contents (cadr pair) (concat yet (car pair))))
            (parse-string-contents rest (concat yet ch)))))

; deftype token = ('tag <field>), where the type of <field> depends on the tag
;   ('open '()) ('close '()) ('quote '()) ('string "text") ('number 123) ('name "name") ('include "path")
; string -> (token string[rest])
(define next-token (str)
    (let ((ch (substr 0 1 str))
          (rest (substr 1 -1 str)))
        (cond
            (= ch "")
                '()
            (isspace? ch)
                (next-token rest)
            (= ch ";")
                (next-token (drop-while (lambda (c) (not (= c "\n"))) rest))
            (= ch "(")
                (list (list 'open '()) rest)
            (= ch ")")
                (list (list 'close '()) rest)
            (= ch "'")
                (list (list 'quote '()) rest)
            (= ch "#")
                (if (= (substr 0 7 rest) "include")
                    (let ((pair (next-token (substr 7 -1 rest))))
                        (cond
                            (null? pair)
                                (error "Expected path after #include")
                            (= (car (car pair)) 'string)
                                (list (list 'include (cadr (car pair))) (cadr pair))
                            (error "Expected string after #include")))
                    (error "Unknown preprocessor directive after '#'"))
            (= ch "\"")
                (let ((pair (parse-string-contents rest ""))
                      (text (car pair))
                      (rest2 (cadr pair)))
                    (list (list 'string text) rest2))
            (or (iswordchar? ch) (isdigit? ch))
                (let ((restword (take-while isrestwordchar? rest))
                      (rest2 (substr (length restword) -1 rest)))
                    (if (and (all isdigit? restword)
                             (or (isdigit? ch) (and (= ch "-") (> (length restword) 0))))
                        (list (list 'number (parse-int (concat ch restword))) rest2)
                        (list (list 'name (concat ch restword)) rest2)))
            (error "Invalid token" ch))))

; string -> (list token...)
(define tokenise (str)
    (let ((helper (lambdarec rec (str2 rev-prefix)
                        (let ((pair (next-token str2)))
                            (if (null? pair)
                                (reverse rev-prefix)
                                (let ((token (car pair))
                                      (rest (cadr pair)))
                                    (rec rest (cons token rev-prefix))))))))
     (helper str '())))

; token -> string
(define pretty-token (token)
    (let ((tag (car token))
          (field (cadr token)))
        (cond
            (= tag 'open)
                (ansi-color 'red "(")
            (= tag 'close)
                (ansi-color 'red ")")
            (= tag 'quote)
                (ansi-color 'green "'")
            (= tag 'string)
                (ansi-color 'yellow (concat "\"" (string-escape field) "\""))
            (= tag 'number)
                (ansi-color 'blue (number->string field))
            (= tag 'name)
                field
            (= tag 'include)
                (concat (ansi-color 'cyan "#include") " " (ansi-color 'yellow (concat "\"" (string-escape field) "\"")))
            (error "Invalid token tag in pretty-token" tag))))

; tokens -> string
(define pretty-token-list (tokens)
    (if (null? tokens)
        ""
        (concat (pretty-token (car tokens)) " " (pretty-token-list (cdr tokens)))))

; (define logged-token-fn (name fn)
;     (lambda (x)
;         (do
;             (print name (pretty-token-list x))
;             (let ((res (fn x)))
;                 (do
;                     (print "->" name (car res) (pretty-token-list (cadr res)))
;                     res)))))

(define logged-token-fn (name fn) fn)

(declare parse-sexpr)

; deftype item = ('tag <field>), where the type of <field> depends on the tag
;   ('string "text") ('number 123) ('name "name") ('quote item) ('sexpr (list item...)) ('include "path")
; tokens -> (item tokens[rest])
(define parse-item (logged-token-fn "parse-item" (lambda (tokens)
    (if (null? tokens)
        (error "Expected value, not end-of-file")
        (let ((tag (car (car tokens))))
            (cond
                (= tag 'open)
                    (parse-sexpr tokens)
                (= tag 'close)
                    (error "Unexpected close parenthesis")
                (= tag 'quote)
                    (let ((pair (parse-item (cdr tokens))))
                        (list (list 'quote (car pair)) (cadr pair)))
                (= tag 'string)
                    (list (car tokens) (cdr tokens))
                (= tag 'number)
                    (list (car tokens) (cdr tokens))
                (= tag 'name)
                    (list (car tokens) (cdr tokens))
                (= tag 'include)
                    (list (car tokens) (cdr tokens))
                (error "Invalid token tag?")))))))

; tokens -> (list[items] tokens[rest])
(define parse-items (logged-token-fn "parse-items" (lambda (tokens)
    (cond
        (null? tokens)
            (list '() '())
        (= (car (car tokens)) 'close)
            (list '() tokens)
        (let ((item-pair (parse-item tokens)))
            (if (null? item-pair)
                (error "??? () from parse-item?")
                (let ((items-pair (parse-items (cadr item-pair))))
                    (list (cons (car item-pair) (car items-pair)) (cadr items-pair)))))))))

; tokens -> (list[items] tokens[rest])
(define parse-sexpr (logged-token-fn "parse-sexpr" (lambda (tokens)
    (if (null? tokens)
        '()
        (if (!= (car (car tokens)) 'open)
            (error "Expected s-expression")
            (let ((items-pair (parse-items (cdr tokens)))
                  (items (car items-pair))
                  (rest (cadr items-pair)))
                (if (null? rest)
                    (error "Missing close parenthesis at end of file")
                    (if (!= (car (car rest)) 'close)
                        (error "Expected close parenthesis to end sexpr")
                        (list (list 'list items) (cdr rest))))))))))

; tokens -> list[items]
(define parse-program (tokens)
    (let ((pair (parse-items tokens))
          (items (car pair))
          (rest (cadr pair)))
        (if (not (null? rest))
            (error "??? Unrecognised extra tokens at end of file")
            (cons 'program items))))

; ast -> string
(define pretty-ast-compact (ast)
    (cond
        (= (car ast) 'program)
            (intercalate " " (map pretty-ast-compact (cdr ast)))
        (= (car ast) 'list)
            (concat "(" (intercalate " " (map pretty-ast-compact (cadr ast))) ")")
        (= (car ast) 'quote)
            (concat "'" (pretty-ast-compact (cadr ast)))
        (= (car ast) 'string)
            (pretty-token ast)
        (= (car ast) 'number)
            (pretty-token ast)
        (= (car ast) 'name)
            (pretty-token ast)
        (= (car ast) 'include)
            (pretty-token ast)
        (error "Unrecognised AST type in pretty-ast-compact" (car ast))))

; ast -> string
(define pretty-ast (ast)
    (let ((isnotnl? (lambda (ch) (!= ch "\n")))
          (indent (lambdarec rec (str)
                        (let ((line (take-while isnotnl? str))
                              (rest (drop-while isnotnl? str)))
                            (if (= rest "")
                                line
                                (concat line "\n    " (rec (substr 1 -1 rest)))))))
          (indent-items (lambdarec rec (items)
                            (if (null? items)
                                ""
                                (concat
                                    (indent (pretty-ast (car items)))
                                    (concat-list
                                        (map (lambda (i) (concat "\n    " (indent (pretty-ast i))))
                                             (cdr items)))))))
          (print-program (lambdarec rec (items)
                            (if (null? items)
                                ""
                                (concat
                                    (pretty-ast (car items))
                                    (concat-list
                                        (map (lambda (i) (concat "\n" (pretty-ast i)))
                                             (cdr items))))))))
        (cond
            (= (car ast) 'program)
                (print-program (cdr ast))
            (= (car ast) 'list)
                (concat "(" (indent-items (cadr ast)) ")")
            (= (car ast) 'quote)
                (concat "'" (pretty-ast-compact (cadr ast)))
            (= (car ast) 'string)
                (pretty-token ast)
            (= (car ast) 'number)
                (pretty-token ast)
            (= (car ast) 'name)
                (pretty-token ast)
            (= (car ast) 'include)
                (pretty-token ast)
            (error "Unrecognised AST type in pretty-ast" (car ast)))))

(let ((tokens (tokenise (read-file "tests/lispparser.lisp"))))
    (do
        ; (print (pretty-token-list tokens))
        ; (print (parse-program tokens))
        (print (pretty-ast (parse-program tokens)))))