Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1363 lines (1215 sloc) 59.1 KB
;; This file specifies the syntax of Toccata
;; It also contains the code to turn a Toccata program from a string
;; to an AST
;; Components to build the grammar out of
(add-ns grmr (git-dependency "https://github.com/Toccata-Lang/grammar.git"
"grammar.toc"
:sha "1e280ff"))
;; The different types of nodes in the AST
(add-ns ast (git-dependency "https://github.com/Toccata-Lang/ast.git"
"ast.toc"
:sha "ffd6095"))
(defn min [x y]
(either (< x y)
y))
;; sometimes, we have to see what's wrong
(defn debug [tag]
(grmr/ignore
(grmr/optional (grmr/term-fn (fn [text]
(print-err tag (count text)
(str "\"" (subs text 0 (min 40 (count text))) "\""))
0)))))
(defn error [msg]
(grmr/apply-fn (fn [file line]
(print-err msg "at" file line)
(abort))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)))
;; we tag symbols with file/line for use later
(defprotocol Tagged
(namespace [s] nothing)
(tag [s] (tag s "" 0))
(tag [s file line] s)
(untag [x] x))
(deftype tagged-symbol [ns base sym file-name line-num]
(assert (instance? Maybe ns))
(assert (instance? Integer line-num))
ast/FileLineInfo
(ast/file-name [s] file-name)
(ast/line-number [s] line-num)
Tagged
(namespace [s] ns)
(tag [s] s)
(tag [s file line]
(tagged-symbol ns base sym file line))
(untag [_] base)
Stringable
(string-list [_]
(list (either (map ns (fn [ns-str] (str ns-str "/" base)))
(str base))))
Hashable
(sha1 [_] (sha1 base))
Eq
(=* [_ x] (=* x base)))
(extend-type Symbol
Tagged
(namespace [s] nothing)
(tag [s]
(tagged-symbol nothing s s "" 0))
(tag [s file line]
(tagged-symbol nothing s s file line))
(untag [s] s))
(extend-type String
Tagged
(tag [s]
(let [s (symbol s)]
(tagged-symbol nothing s s "" 0)))
(tag [s file line]
(let [s (symbol s)]
(tagged-symbol nothing s s file line))))
;; It's useful to be able to tag lists of symbols
(extend-type List
Tagged
(tag [l file line]
(map l (fn [x]
(tag x file line)))))
(def symbol-start
(grmr/rule "symbol-start"
(grmr/any grmr/alpha (grmr/one-of "._<>=+-*/"))))
(def symbol-punct
(grmr/rule "symbol-punct"
(grmr/one-of "._<>=+-*/!?")))
(def symbol-char
(grmr/rule "symbol-char"
(grmr/any grmr/alpha grmr/digit symbol-punct)))
(def rest-of-symbol
(grmr/rule "rest-of-symbol"
(grmr/none-or-more symbol-char)))
(def namespace-punct
(grmr/rule "namespace-punct"
(grmr/one-of "._<>=*+!-?")))
(def rest-of-namespace
(grmr/rule "rest-of-namespace"
(grmr/none-or-more (grmr/any grmr/alpha
grmr/digit
namespace-punct))))
(def read-namespace
(grmr/rule "namespace"
(grmr/apply-fn (fn [start the-rest]
(symbol (to-str (comp [start] the-rest))))
grmr/alpha
rest-of-namespace
(grmr/ignore "/"))))
(def read-symbol
(grmr/rule "tagged-symbol"
(grmr/apply-fn (fn [file-name line-number ns start the-rest]
(let [ns-prefix (either (= "" ns)
(str ns "/"))]
(tagged-symbol ns
(symbol (to-str (comp [start] the-rest)))
(symbol (to-str (comp (list ns-prefix start)
the-rest)))
file-name line-number)))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/optional read-namespace)
symbol-start
rest-of-symbol)))
(def read-string-newline
(grmr/rule "newline"
(grmr/apply-fn (fn [& _] "\n")
(grmr/all "\\" "n"))))
(def read-string-tab
(grmr/rule "tab"
(grmr/apply-fn (fn [& _] "\t")
(grmr/all "\\" "t"))))
(def read-string-backspace
(grmr/rule "backspace"
(grmr/apply-fn (fn [& _] "\b")
(grmr/all "\\" "b"))))
(def read-string-return
(grmr/rule "return"
(grmr/apply-fn (fn [& _] "\r")
(grmr/all "\\" "r"))))
(def read-string-formfeed
(grmr/rule "formfeed"
(grmr/apply-fn (fn [& _] "\f")
(grmr/all "\\" "f"))))
(def read-string-doublequote
(grmr/rule "doublequote"
(grmr/apply-fn (fn [& _] "\"")
(grmr/all "\\" "\""))))
(def read-string-backslash
(grmr/rule "backslash"
(grmr/apply-fn (fn [& _] "\\")
(grmr/all "\\" "\\"))))
(def not-eol
(grmr/rule "not-eol"
(grmr/not-char "\n")))
(defn string-frag-len [s]
(assert (instance? String s))
(inline C Integer "
char *str = NULL;
int64_t strLen;
if (s_0->type == StringBufferType) {
str = ((String *)s_0)->buffer;
strLen = ((String *)s_0)->len;
} else if (s_0->type == SubStringType) {
str = ((SubString *)s_0)->buffer;
strLen = ((SubString *)s_0)->len;
}
int64_t len;
for (len = 0; len < strLen && str[len] != 34 && str[len] != 92;)
len++;
dec_and_free(s_0, 1);
return(integerValue(len));
"))
(def read-string-fragment
(grmr/rule "read-string-fragment"
(grmr/term-fn (fn [text]
(string-frag-len text)))))
(def read-string
(grmr/rule "string"
(grmr/apply-fn to-str
(grmr/ignore "\"")
(grmr/none-or-more
(grmr/any read-string-fragment
read-string-backslash
read-string-doublequote
read-string-tab
read-string-backspace
read-string-return
read-string-formfeed
read-string-newline))
(grmr/ignore "\""))))
(def read-string-literal
(grmr/rule "string"
(grmr/apply-fn (fn [file-name line-num frags]
(ast/string-ast (to-str frags) file-name line-num))
(grmr/ignore "\"")
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/none-or-more
(grmr/any read-string-fragment
read-string-backslash
read-string-doublequote
read-string-tab
read-string-backspace
read-string-return
read-string-formfeed
read-string-newline))
(grmr/ignore "\""))))
(def read-integer
(grmr/rule "number"
(grmr/any (grmr/apply-fn (fn [digits]
(str-to-int (to-str digits)))
(grmr/one-or-more grmr/digit))
(grmr/apply-fn (fn [digits]
(* -1 (str-to-int (to-str digits))))
(grmr/ignore "-")
(grmr/one-or-more grmr/digit)))))
(def read-integer-literal
(grmr/rule "number"
(grmr/any (grmr/apply-fn (fn [file-name line-num digits]
(ast/integer-ast (str-to-int (to-str digits))
file-name line-num))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/one-or-more grmr/digit))
(grmr/apply-fn (fn [file-name line-num digits]
(ast/integer-ast (* -1 (str-to-int (to-str digits)))
file-name line-num))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/ignore "-")
(grmr/one-or-more grmr/digit)))))
(def read-sub-expr
(grmr/recurse "expr"))
(def linear-whitespace
(grmr/rule "linear-whitespace"
(grmr/any "," " " "\t")))
(def ignore-linear-whitespace (grmr/ignore (grmr/none-or-more linear-whitespace)))
(def newline
(grmr/rule "newline"
(grmr/apply-fn identity
"\n" (grmr/ignore (grmr/update-value 'line-number inc)))))
(def ignore-newlines (grmr/ignore (grmr/none-or-more newline)))
(def whitespace
(grmr/rule "whitespace"
(grmr/any linear-whitespace
"\r"
newline)))
(def ignore-whitespace (grmr/ignore (grmr/none-or-more whitespace)))
(def read-arg
(grmr/rule "arg"
(grmr/apply-fn comp
ignore-whitespace
read-symbol
ignore-whitespace)))
(def read-var-arg
(grmr/rule "var-arg"
(grmr/apply-fn identity
ignore-whitespace
(grmr/ignore "&")
read-arg)))
(def read-open-paren
(grmr/rule "open-paren"
(grmr/ignore (grmr/all ignore-whitespace "(" ignore-whitespace))))
(def read-close-paren
(grmr/rule "close-paren"
(grmr/ignore (grmr/all ignore-whitespace ")"))))
(def read-inline
(grmr/rule "read-inline"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "inline")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/apply-fn (fn [file-name line-number lang return-type body]
(ast/inline-ast lang return-type body
file-name line-number))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
read-symbol
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/optional (grmr/apply-fn identity
read-symbol
(grmr/ignore
(grmr/one-or-more whitespace))))
read-string
read-close-paren))))
(def read-block-comment
(grmr/rule "block-comment"
(grmr/apply-fn ast/block-comment
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/one-or-more
(grmr/apply-fn identity
ignore-whitespace
(grmr/ignore (grmr/one-or-more ";"))
(grmr/apply-fn to-str
(grmr/none-or-more not-eol))
(grmr/ignore newline))))))
(def ignore-comment
(grmr/ignore read-block-comment))
(def read-call
(grmr/rule "call"
(grmr/apply-fn ast/call-expr
read-open-paren
(grmr/one-or-more read-sub-expr)
read-close-paren)))
(def read-sub-dest
(grmr/recurse "destructure"))
(def read-list-destructure
(grmr/rule "list-destructure"
(grmr/apply-fn ast/params
ignore-whitespace
(grmr/ignore "[")
(grmr/none-or-more read-sub-dest)
(grmr/any (grmr/apply-fn maybe read-var-arg)
(grmr/always nothing))
(grmr/ignore "]"))))
(def read-destructure
(grmr/recursive-rule "destructure"
(grmr/any read-list-destructure
read-arg)))
(def read-let-binding
;; TODO: accept comments as well
(grmr/rule "let-binding"
(grmr/apply-fn ast/binding
ignore-whitespace
(grmr/ignore (grmr/optional read-block-comment))
ignore-whitespace
read-destructure
read-sub-expr)))
(def read-let
(grmr/rule "let"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "let")
ignore-whitespace
(grmr/ignore "[")
(grmr/any (grmr/apply-fn ast/let-expr
(grmr/one-or-more read-let-binding)
(grmr/ignore "]")
(grmr/one-or-more read-sub-expr)
read-close-paren)
(error "Invalid 'let' expression")))))
(def read-do
(grmr/rule "do"
(grmr/apply-fn (partial ast/let-expr [])
read-open-paren
(grmr/ignore "do")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/one-or-more read-sub-expr)
read-close-paren)))
(def read-or
(grmr/rule "or"
(grmr/apply-fn (fn [or-clauses]
(either (first or-clauses)
(do
(print-err 'WTF)
(abort)))
(ast/or-expr or-clauses))
read-open-paren
(grmr/ignore "or")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/one-or-more read-sub-expr)
read-close-paren)))
(def read-and
(grmr/rule "and"
(grmr/apply-fn (fn [and-clauses]
(either (first and-clauses)
(do
(print-err 'WTF)
(abort)))
(ast/and-expr and-clauses))
read-open-paren
(grmr/ignore "and")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/one-or-more read-sub-expr)
read-close-paren)))
(def read-either
(grmr/rule "either"
(grmr/apply-fn ast/either-expr
read-open-paren
(grmr/ignore "either")
(grmr/ignore (grmr/one-or-more whitespace))
;; TODO: make sure no literal values are here
;; TODO: allow comments in either expr
read-sub-expr
read-sub-expr
read-close-paren)))
(def read-min-count-assertion
(grmr/rule "assert-min-count"
(grmr/apply-fn ast/assert-min-count
read-open-paren
ignore-whitespace
(grmr/ignore "min-count")
(grmr/ignore (grmr/one-or-more whitespace))
read-symbol
(grmr/ignore (grmr/one-or-more whitespace))
read-integer
read-close-paren)))
(def read-sub-type-expr
(grmr/recurse "type-expr"))
(def read-list-assertion
(grmr/rule "assert-list-of"
(grmr/apply-fn ast/assert-list-of
read-open-paren
ignore-whitespace
(grmr/ignore "list-of")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-type-expr
read-close-paren)))
(def read-maybe-assertion
(grmr/rule "assert-maybe-of"
(grmr/apply-fn ast/assert-maybe-of
read-open-paren
ignore-whitespace
(grmr/ignore "maybe-of")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-type-expr
read-close-paren)))
(def read-vector-assertion
(grmr/rule "assert-vector-of"
(grmr/apply-fn ast/assert-vector-of
read-open-paren
ignore-whitespace
(grmr/ignore "vector-of")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-type-expr
read-close-paren)))
(def read-map-assertion
(grmr/rule "assert-map-of"
(grmr/apply-fn ast/assert-map-of
read-open-paren
ignore-whitespace
(grmr/ignore "map-of")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-type-expr
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-type-expr
read-close-paren)))
(def read-type-expr
(grmr/recursive-rule "type-expr"
(grmr/any read-symbol
read-maybe-assertion
read-map-assertion
read-vector-assertion
read-list-assertion)))
(def read-type-assertion
(grmr/rule "assert-type"
(grmr/apply-fn ast/assert-type
read-open-paren
ignore-whitespace
(grmr/ignore "instance?")
(grmr/ignore (grmr/one-or-more whitespace))
read-type-expr
(grmr/ignore (grmr/one-or-more whitespace))
read-symbol
read-close-paren)))
(def read-max-val-assertion
(grmr/rule "assert-max"
(grmr/apply-fn ast/assert-max-value
read-open-paren
ignore-whitespace
(grmr/ignore "max")
(grmr/ignore (grmr/one-or-more whitespace))
read-integer
(grmr/ignore (grmr/one-or-more whitespace))
read-symbol
read-close-paren)))
(def read-min-val-assertion
(grmr/rule "assert-min"
(grmr/apply-fn ast/assert-min-value
read-open-paren
ignore-whitespace
(grmr/ignore "min")
(grmr/ignore (grmr/one-or-more whitespace))
read-integer
(grmr/ignore (grmr/one-or-more whitespace))
read-symbol
read-close-paren)))
(def read-assert
(grmr/rule "assert"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "assert")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-type-assertion
read-min-count-assertion
read-min-val-assertion
read-max-val-assertion)
read-close-paren)))
(def read-assert-result
(grmr/rule "assert-result"
(grmr/apply-fn ast/result-expr
read-open-paren
(grmr/ignore "assert-result")
(grmr/ignore (grmr/one-or-more whitespace))
read-symbol
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-type-assertion
read-min-val-assertion
read-max-val-assertion)
read-close-paren)))
(def read-comp
(grmr/rule "comp"
(grmr/apply-fn identity
(grmr/ignore "(")
ignore-whitespace
(grmr/ignore "comp")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/apply-fn
(fn [arg args]
(let [file-name (ast/file-name arg)
line-number (ast/line-number arg)
comp** (tag 'comp* file-name line-number)
list* (tag 'list file-name line-number)]
(ast/call-expr [comp** arg
(ast/call-expr (cons list*
(seq args)))])))
read-sub-expr
(grmr/none-or-more read-sub-expr)
ignore-whitespace
(grmr/ignore ")"))
(error "Invalid 'comp' form")))))
(def read-apply-to
(grmr/rule "apply-to"
(grmr/apply-fn identity
(grmr/ignore "(")
ignore-whitespace
(grmr/ignore "apply-to")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/apply-fn
(fn [fn ln f arg args]
(let [file-name (ast/file-name f)
line-number (ast/line-number f)
apply* (tag 'apply file-name line-number)
wrap* (tag 'wrap file-name line-number)
list (tag 'list file-name line-number)]
(ast/let-expr
[(ast/binding-ast (tag "#x" fn ln) arg)]
[(ast/call-expr
[apply*
(ast/call-expr [wrap* (tag "#x" fn ln) f])
(ast/call-expr (list* list arg (seq args)))])])))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
read-sub-expr
read-sub-expr
(grmr/none-or-more read-sub-expr)
ignore-whitespace
(grmr/ignore ")"))
(error "Invalid 'apply-to' form")))))
(def read-inline-body
(grmr/rule "read-inline-body"
(grmr/apply-fn comp
(grmr/none-or-more (grmr/any read-assert
read-assert-result
read-block-comment))
ignore-whitespace
(grmr/all read-inline)
(grmr/none-or-more read-block-comment))))
(def read-fn-doc
(grmr/rule "fn-doc"
(grmr/any read-block-comment
(grmr/apply-fn (fn [fn ln]
(ast/block-comment fn ln [""]))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)))))
(def read-single-arity
(grmr/rule "single-arity"
(grmr/apply-fn (fn [params doc body]
(ast/fn-arity params doc body))
read-list-destructure
read-fn-doc
(grmr/any read-inline-body
(grmr/one-or-more read-sub-expr)
(error "Body of function is wrong"))
ignore-whitespace)))
(def read-arities
(grmr/rule "arities"
(grmr/any (grmr/apply-fn vector read-single-arity)
(grmr/apply-fn (fn [doc arities]
(vec (map arities (fn [arity]
(.doc arity doc)))))
read-fn-doc
(grmr/one-or-more (grmr/apply-fn identity
read-open-paren
read-single-arity
read-close-paren))))))
(def read-fn
(grmr/rule "fn"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "fn")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/apply-fn (fn [name arities]
(ast/fn-expr name arities))
(grmr/optional read-symbol)
ignore-whitespace
read-arities
read-close-paren)
(error "Invalid 'fn' expression")))))
(def TypeCount (inline C Integer "(Value *)&(Integer){IntegerType, -1, TypeCount};"))
(def type-counter (int-generator TypeCount))
(def read-impl-arity
(grmr/rule "impl-arity"
(grmr/apply-fn (fn [params doc body]
(ast/fn-arity params doc body))
(grmr/apply-fn ast/params
ignore-whitespace
(grmr/ignore "[")
(grmr/one-or-more read-sub-dest)
(grmr/any (grmr/apply-fn maybe read-var-arg)
(grmr/always nothing))
(grmr/ignore "]"))
read-fn-doc
(grmr/any read-inline-body
(grmr/one-or-more read-sub-expr)
(error "Body of function is wrong"))
ignore-whitespace)))
(def read-implementation
(grmr/rule "protocol-implementation"
(grmr/all read-open-paren
read-symbol
(grmr/apply-fn list read-impl-arity)
read-close-paren)))
(def read-proto-impls
(grmr/rule "protocol-implementations"
(grmr/any (grmr/apply-fn hash-map
ignore-whitespace
read-symbol
(grmr/one-or-more read-implementation))
read-assert
(grmr/apply-fn (fn [_] {})
read-block-comment))))
(def read-reify
(grmr/rule "reify"
(grmr/apply-fn (fn [impls]
(ast/reified (extract type-counter) impls))
read-open-paren
(grmr/ignore "reify")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/apply-fn comp*
read-proto-impls
(grmr/none-or-more read-proto-impls))
read-close-paren)))
(def curr-file-name
(grmr/rule "_FILE_"
(grmr/apply-fn (fn [file-name line-num]
(ast/string-ast file-name file-name line-num))
ignore-whitespace
(grmr/ignore "_FILE_")
(grmr/get-value 'file-name)
(grmr/get-value 'line-number))))
(def curr-line
(grmr/rule "_LINE_"
(grmr/apply-fn identity
ignore-whitespace
(grmr/ignore "_LINE_")
(grmr/get-value 'line-number))))
(def read-vector
(grmr/rule "vector"
(grmr/apply-fn identity
(grmr/ignore "[")
(grmr/apply-fn (fn [fn ln elems]
(ast/call-expr (cons (tag 'vector fn ln)
(seq elems))))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/none-or-more read-sub-expr)
(grmr/any (grmr/ignore "]")
(error "Missing \"]\""))))))
(def read-hash-map
(grmr/rule "hash-map"
(grmr/apply-fn identity
(grmr/ignore "{")
(grmr/apply-fn (fn [fn ln elems]
(ast/call-expr (cons (tag 'hash-map fn ln)
(comp* empty-list elems))))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/none-or-more (grmr/all read-sub-expr
read-sub-expr))
(grmr/any (grmr/ignore "}")
(error "Missing \"}\""))))))
(def read-hash-set
(grmr/rule "hash-set"
(grmr/apply-fn identity
(grmr/ignore "#{")
(grmr/apply-fn (fn [fn ln elems]
(ast/call-expr (cons (tag 'hash-set fn ln)
(seq elems))))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/none-or-more read-sub-expr)
(grmr/any (grmr/ignore "}")
(error "Missing \"}\""))))))
(defprotocol QuoteLiteral
(quote-literal [quoted]
(ast/quoted quoted)))
(extend-type ast/string-ast
QuoteLiteral
(quote-literal [n] n))
(extend-type ast/integer-ast
QuoteLiteral
(quote-literal [n] n))
(extend-type String
QuoteLiteral
(quote-literal [n] n))
(extend-type Integer
QuoteLiteral
(quote-literal [n] n))
(extend-type List
QuoteLiteral
(quote-literal [quoted-list]
(either (or (for [head (first quoted-list)
:when (= head 'quoted)
ast (quote-literal (rest quoted-list))]
ast)
(for [coll-builder (first quoted-list)
:when (or (= coll-builder 'hash-map)
(= coll-builder 'vector))
:let [frms (rest quoted-list)]
contents (or (empty? frms)
(maybe (map frms quote-literal)))]
(ast/call-ast (tag 'vector (ast/file-name quoted-list)
(ast/line-number quoted-list))
(vec contents))))
(ast/call-ast (tag 'list (ast/file-name quoted-list) (ast/line-number quoted-list))
(vec (map quoted-list quote-literal))))))
(extend-type Vector
QuoteLiteral
(quote-literal [quoted-vect]
(either (or (for [head (first quoted-vect)
:when (= head 'quoted)
ast (quote-literal (rest quoted-vect))]
ast)
(for [coll-builder (first quoted-vect)
:when (or (= coll-builder 'hash-map)
(= coll-builder 'vector))
:let [frms (rest quoted-vect)]
contents (or (empty? frms)
(maybe (map frms quote-literal)))]
(ast/call-ast (tag 'vector (ast/file-name quoted-vect) (ast/line-number quoted-vect))
contents)))
(ast/call-ast (tag 'list (ast/file-name quoted-vect) (ast/line-number quoted-vect))
(map quoted-vect quote-literal)))))
(def read-quoted-value
(grmr/recursive-rule "quoted-value"
(grmr/apply-fn identity
ignore-whitespace
(grmr/any (grmr/apply-fn identity
read-open-paren
(grmr/none-or-more
(grmr/recurse "quoted-value"))
read-close-paren)
(grmr/apply-fn (fn [xs]
(cons 'vector (seq xs)))
(grmr/ignore "[")
(grmr/one-or-more
(grmr/recurse "quoted-value"))
(grmr/ignore "]"))
read-integer-literal
read-string-literal
read-symbol)
ignore-whitespace)))
(def read-quoted
(grmr/rule "quoted"
(grmr/apply-fn quote-literal
(grmr/ignore "'")
read-quoted-value)))
(defprotocol ForBinding
(nest-let [body bindings]
(ast/let-expr bindings [body]))
(nest-when [body clause wrapper]
(let [fn (ast/file-name clause)
ln (ast/line-number clause)]
(ast/call-ast
(tag 'extract fn ln)
[(ast/or-expr
[(ast/and-expr [clause (ast/call-ast (tag 'maybe fn ln) [body])])
(ast/call-ast (tag 'maybe fn ln)
[(ast/call-ast (tag 'zero fn ln)
[(ast/call-ast (tag 'zero fn ln)
[wrapper])])])])])))
(nest-when-not [body clause wrapper]
(let [fn (ast/file-name clause)
ln (ast/line-number clause)]
(ast/call-ast
(tag 'extract fn ln)
[(ast/or-expr
[(ast/and-expr
[clause (ast/call-ast (tag 'maybe fn ln)
[(ast/call-ast (tag 'zero fn ln)
[wrapper])])])
(ast/call-ast (tag 'maybe fn ln) [body])])])))
(nest-binding [body binding wrapper]))
(extend-type ast/let-ast
ForBinding
(nest-binding [body binding wrapper]
(ast/call-ast (tag 'flat-map (ast/file-name binding) (ast/line-number binding))
[(.val binding)
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(.binding binding)]) ""
[body])])])))
(extend-type ast/call-ast
ForBinding
(nest-binding [body binding wrapper]
(ast/call-ast (tag 'flat-map (ast/file-name binding) (ast/line-number binding))
[(.val binding)
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(.binding binding)]) ""
[body])])])))
(extend-type ast/binding-ast
ForBinding
(nest-binding [b body wrapper]
(nest-binding body b wrapper)))
(deftype ForLetExpr [bindings]
(assert (instance? Vector bindings))
Stringable
(string-list [_] (comp (list "<ForLet")
(string-list bindings)
(list ">")))
ForBinding
(nest-binding [_ body wrapper]
(nest-let body bindings)))
(def read-for-let
(grmr/rule "for-let"
(grmr/apply-fn (fn [bindings]
(ForLetExpr bindings))
(grmr/any ignore-whitespace
ignore-comment)
(grmr/ignore ":let")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/ignore "[")
(grmr/one-or-more read-let-binding)
(grmr/ignore "]")
ignore-whitespace)))
(deftype ForWhenExpr [value]
Stringable
(string-list [_] (comp (list "<ForWhen")
(string-list value)
(list ">")))
ForBinding
(nest-binding [_ body wrapper]
(nest-when body value wrapper)))
(def read-for-when
(grmr/rule "for-when"
(grmr/apply-fn (fn [clause]
(ForWhenExpr clause))
(grmr/any ignore-whitespace
ignore-comment)
(grmr/ignore ":when")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-expr)))
(deftype ForWhenNotExpr [value]
Stringable
(string-list [_] (comp (list "<ForWhenNot")
(string-list value)
(list ">")))
ForBinding
(nest-binding [_ body wrapper]
(nest-when-not body value wrapper)))
(def read-for-when-not
(grmr/rule "for-when-not"
(grmr/apply-fn (fn [clause]
(ForWhenNotExpr clause))
(grmr/any ignore-whitespace
ignore-comment)
(grmr/ignore ":when-not")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-expr)))
(deftype ForResultExpr [body]
ForBinding
(nest-let [_ bindings]
(ForResultExpr (nest-let body bindings)))
(nest-when [_ clause wrapper]
(let [fn (ast/file-name clause)
ln (ast/line-number clause)]
(ast/call-ast
(tag 'flat-map fn ln)
[(ast/call-ast
(tag 'extract fn ln)
[(ast/or-expr
[(ast/and-expr [clause
(ast/call-ast
(tag 'maybe fn ln)
[(ast/call-ast (tag 'wrap fn ln)
[wrapper body])])])
(ast/call-ast
(tag 'maybe fn ln)
[(ast/call-ast (tag 'zero fn ln)
[(ast/call-ast (tag 'zero fn ln)
[wrapper])])])])])
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(tag "#x" fn ln)]) ""
[(ast/call-ast (tag 'wrap fn ln)
[wrapper (tag "#x" fn ln)])])])])))
(nest-when-not [_ clause wrapper]
(let [fn (ast/file-name clause)
ln (ast/line-number clause)]
(ast/call-ast
(tag 'flat-map fn ln)
[(ast/call-ast
(tag 'extract fn ln)
[(ast/or-expr
[(ast/and-expr [clause
(ast/call-ast
(tag 'maybe fn ln)
[(ast/call-ast (tag 'zero fn ln) [wrapper])])])
(ast/call-ast
(tag 'maybe fn ln)
[(ast/call-ast (tag 'wrap fn ln) [wrapper body])])])])
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(tag "#x" fn ln)]) ""
[(ast/call-ast (tag 'wrap fn ln)
[wrapper (tag "#x" fn ln)])])])])))
(nest-binding [_ binding wrapper]
(let [fn (ast/file-name binding)
ln (ast/line-number binding)]
(ast/call-ast (tag 'flat-map fn ln)
[(.val binding)
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(.binding binding)]) ""
[(ast/call-ast (tag 'wrap fn ln)
[wrapper body])])])])))
Stringable
(string-list [_] (comp (list "<ForResult ")
(string-list body)
(list ">"))))
(defn nest-for-exprs [bogus bindings body]
(let [wrapper (tag "#wrapper")
wrapper-binding (ForLetExpr [(ast/binding wrapper (.val bogus))])
bindings (remove bindings (fn [bogus]
(instance? ast/block-comment-ast bogus)))
bindings (reverse (comp (list wrapper-binding
(ast/binding (.binding bogus) wrapper))
bindings))]
(reduce bindings (ForResultExpr body)
(fn [body expr]
(nest-binding expr body wrapper)))))
(def read-for-binding
(grmr/rule "for-binding"
(grmr/any read-for-let
read-for-when
read-for-when-not
read-let-binding
(grmr/apply-fn identity
read-block-comment
ignore-whitespace))))
(def read-for
(grmr/rule "for"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "for")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/apply-fn nest-for-exprs
(grmr/ignore "[")
(grmr/any read-let-binding
(error "Invalid initial 'for' bindings"))
(grmr/any (grmr/none-or-more read-for-binding)
(error "Invalid 'for' bindings"))
(grmr/ignore "]")
;; TODO: allow comments in body
(grmr/any read-sub-expr
(error "Invalid 'for' body")))
(error "Invalid 'for' expression"))
read-close-paren)))
(defn nest-thread-exprs [first-expr exprs]
(let [[first-expr & exprs] (remove (cons first-expr (seq exprs))
(partial instance? ast/NoCode))]
(reduce exprs first-expr (fn [threaded expr]
(ast/call-ast (.call-target expr)
(comp [threaded] (.args expr)))))))
(def read-thread-expr
(grmr/rule "->exp"
(grmr/any (grmr/apply-fn identity
(grmr/any (grmr/apply-fn ast/call-expr
(grmr/all read-symbol))
read-call)
ignore-whitespace)
read-block-comment)))
(def read-threading
(grmr/rule "->"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "->")
(grmr/any (grmr/apply-fn nest-thread-exprs
read-sub-expr
(grmr/one-or-more read-thread-expr))
(error "Invalid '->' expression"))
read-close-paren)))
(def read-expr
(grmr/recursive-rule "expr"
(grmr/apply-fn identity
ignore-whitespace
(grmr/any read-integer-literal
read-string-literal
curr-file-name
curr-line
read-symbol
read-quoted
read-or
read-and
read-either
read-fn
read-let
read-do
read-comp
read-apply-to
read-reify
read-vector
read-hash-map
read-hash-set
read-for
read-threading
read-assert
read-assert-result
(grmr/all read-inline
(error "'inline' expressions not allowed here"))
read-call
read-block-comment)
ignore-whitespace)))
(def read-main
(grmr/rule "main"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "main")
(grmr/any (grmr/apply-fn ast/main-fn
read-list-destructure
(grmr/any read-inline-body
(grmr/one-or-more read-expr)
(error "Body of 'main' fn is wrong"))
read-close-paren)
(error "'main' fn expression is wrong")))))
(def read-def
(grmr/rule "def"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "def")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/apply-fn (fn [sym pre-comment value post-comment]
(ast/definition sym (comp pre-comment
(list value)
post-comment)))
read-symbol
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/none-or-more read-block-comment)
(grmr/any read-inline
read-expr)
ignore-whitespace
(grmr/none-or-more read-block-comment)
read-close-paren)
(grmr/apply-fn ast/declare
read-symbol
read-close-paren)
(error "Invalid 'def' expression")))))
(def read-prototype
(grmr/rule "prototype"
(grmr/any read-assert
(grmr/apply-fn identity
read-open-paren
(grmr/any
(grmr/apply-fn ast/prototype
read-symbol
read-list-destructure
read-fn-doc
(grmr/any read-inline-body
(grmr/none-or-more read-expr))
read-close-paren)
(error "Invalid prototype function"))))))
(def read-defprotocol
(grmr/rule "defprotocol"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "defprotocol")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/apply-fn (fn [sym prototypes]
(ast/protocol
sym (remove prototypes (partial instance? ast/NoCode))))
read-symbol
(grmr/one-or-more
(grmr/any read-block-comment
read-prototype))
read-close-paren)
(error "Invalid 'defprotocol' expression")))))
(def read-defn
(grmr/rule "defn"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "defn")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/apply-fn (fn [name arities]
(ast/definition name
(list (ast/fn-expr (maybe name)
arities))))
read-symbol
(grmr/ignore (grmr/one-or-more whitespace))
read-arities
read-close-paren)
(error "Invalid 'defn' expression")))))
(def read-extend-type
(grmr/rule "extend-type"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "extend-type")
(grmr/any (grmr/apply-fn ast/type-extension
(grmr/ignore
(grmr/one-or-more whitespace))
read-symbol
(grmr/one-or-more read-proto-impls)
read-close-paren)
(error "Invalid 'extend-type' expression")))))
(def read-deftype
(grmr/rule "deftype"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "deftype")
(grmr/any (grmr/apply-fn ast/type-expr
(grmr/ignore
(grmr/one-or-more whitespace))
read-symbol
read-list-destructure
(grmr/none-or-more read-proto-impls)
read-close-paren)
(error "invalid 'deftype' expression")))))
(def read-JS-callable
(grmr/rule "JS-callable"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "JS-callable")
(grmr/any (grmr/apply-fn (fn [sym num-args]
(ast/JS-callable sym num-args))
(grmr/ignore
(grmr/one-or-more whitespace))
read-symbol
(grmr/ignore
(grmr/one-or-more whitespace))
read-integer
read-close-paren)
(error "invalid 'JS-callable' expression")))))
(defn kw-string-arg [kw-sym]
(grmr/apply-fn (fn [kw-sym value]
[(symbol kw-sym) value])
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/ignore ":")
kw-sym
(grmr/ignore
(grmr/one-or-more whitespace))
read-string))
(def read-git-kwargs
(grmr/rule "git-kwargs"
(grmr/apply-fn (fn [kv-pairs]
(reduce kv-pairs {} (fn [m [k v]]
(assoc m k v))))
(grmr/none-or-more
(grmr/any (kw-string-arg "tag")
(kw-string-arg "sha")
(kw-string-arg "branch"))))))
(def read-git-dep-spec
(grmr/rule "git-dep"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "git-dependency")
(grmr/any (grmr/apply-fn ast/git-dep
(grmr/ignore
(grmr/one-or-more whitespace))
read-string
(grmr/ignore
(grmr/one-or-more whitespace))
read-string
read-git-kwargs
read-close-paren)
(error "Invalid 'git-dependency' expression")))))
(def read-module-spec
(grmr/rule "module"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "module")
(grmr/any (grmr/apply-fn ast/module
(grmr/ignore
(grmr/one-or-more whitespace))
read-string
read-close-paren)
(error "Invalid 'module' expression")))))
(def read-add-ns
(grmr/rule "add-ns"
(grmr/apply-fn identity
read-open-paren
(grmr/ignore "add-ns")
(grmr/any (grmr/apply-fn ast/ns-add
(grmr/ignore
(grmr/one-or-more whitespace))
read-symbol
(grmr/any read-module-spec
read-git-dep-spec)
read-close-paren)
(error "Invalid 'add-ns' expression")))))
(def bad-expr
(grmr/rule "bad-expr"
(grmr/all ignore-whitespace "("
(error "Invalid expression"))))
(def shebang (grmr/apply-fn (fn []
;; just a dummy ast that does nothing
(ast/inline-ast 'C nothing "" "" 0))
(grmr/ignore (grmr/all "#!"
(grmr/none-or-more not-eol)
newline))))
(def top-level
(grmr/recursive-rule "top-level"
(grmr/any read-main
read-JS-callable
read-inline
read-def
read-defprotocol
read-defn
read-extend-type
read-deftype
read-block-comment
read-add-ns
shebang
bad-expr)))
You can’t perform that action at this time.