Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
;; 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 "4846add"))
;; The different types of nodes in the AST
(add-ns ast (git-dependency "https://github.com/Toccata-Lang/ast.git"
"ast.toc"
:sha "a1a3616"))
(add-ns c (git-dependency "https://github.com/Toccata-Lang/constraints.git"
"constraints.toc"
:sha "283961b"))
(defn min [x y]
(either (< x y)
y))
;; sometimes, we have to see what's wrong
(defn debug [tag]
(grmr/ignore
(apply-to (fn [file text]
(cond
(= 'core file) 0
(print-err tag (count text)
(str "\"" (subs text 0 (min 40 (count text))) "\""))))
(grmr/get-value 'file-name)
grmr/get-text)))
(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"
(apply-to (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"
(apply-to (fn [file-name line-number ns start the-rest]
(let [ns-prefix (either (map ns (fn [ns]
(str ns "/")))
"")]
(ast/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"
(apply-to (fn [& _] "\n")
(grmr/all "\\" "n"))))
(def read-string-tab
(grmr/rule "tab"
(apply-to (fn [& _] "\t")
(grmr/all "\\" "t"))))
(def read-string-backspace
(grmr/rule "backspace"
(apply-to (fn [& _] "\b")
(grmr/all "\\" "b"))))
(def read-string-return
(grmr/rule "return"
(apply-to (fn [& _] "\r")
(grmr/all "\\" "r"))))
(def read-string-formfeed
(grmr/rule "formfeed"
(apply-to (fn [& _] "\f")
(grmr/all "\\" "f"))))
(def read-string-doublequote
(grmr/rule "doublequote"
(apply-to (fn [& _] "\"")
(grmr/all "\\" "\""))))
(def read-string-backslash
(grmr/rule "backslash"
(apply-to (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"
(apply-to 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"
(apply-to (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 (apply-to (fn [digits]
(str-to-int (to-str digits)))
(grmr/one-or-more grmr/digit))
(apply-to (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 (apply-to (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))
(apply-to (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"
(apply-to identity
(grmr/string-terminal "\n")
(grmr/ignore (grmr/update-value 'line-number inc)))))
(def ignore-newlines (grmr/ignore (grmr/none-or-more newline)))
(def read-block-comment
(grmr/rule "block-comment"
(apply-to ast/block-comment
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/one-or-more
(apply-to identity
(grmr/ignore (grmr/none-or-more (grmr/any linear-whitespace
"\r"
newline)))
(grmr/ignore (grmr/one-or-more ";"))
(apply-to to-str
(grmr/none-or-more not-eol))
(grmr/ignore newline))))))
(def whitespace
(grmr/rule "whitespace"
(grmr/any (grmr/all (grmr/one-or-more ";")
(grmr/none-or-more not-eol)
newline)
linear-whitespace
"\r"
newline)))
(def ignore-whitespace (grmr/ignore (grmr/none-or-more whitespace)))
(def read-arg
(grmr/rule "arg"
(apply-to comp
ignore-whitespace
read-symbol
ignore-whitespace)))
(def read-var-arg
(grmr/rule "var-arg"
(apply-to 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/any (grmr/ignore (grmr/all ignore-whitespace ")"))
(grmr/error "Missing \")\"."))))
(def read-open-bracket
(grmr/rule "open-bracket"
(grmr/any (grmr/ignore (grmr/all ignore-whitespace "[" ignore-whitespace))
(grmr/error "Missing \"[\"."))))
(def read-close-bracket
(grmr/rule "close-bracket"
(grmr/any (grmr/ignore (grmr/all ignore-whitespace "]"))
(grmr/error "Missing \"]\"."))))
(def read-call
(grmr/rule "call"
(apply-to 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"
(apply-to ast/params
ignore-whitespace
(grmr/ignore "[")
(grmr/none-or-more read-sub-dest)
(grmr/any (apply-to maybe read-var-arg)
(grmr/always nothing))
read-close-bracket)))
(def read-destructure
(grmr/recursive-rule "destructure"
(grmr/any read-list-destructure
read-arg)))
(def read-let-binding
(grmr/rule "let-binding"
(apply-to ast/binding
ignore-whitespace
read-destructure
read-sub-expr)))
(def read-let
(grmr/rule "let"
(apply-to identity
read-open-paren
(grmr/ignore "let")
ignore-whitespace
(grmr/ignore "[")
(grmr/any (apply-to ast/let-expr
(grmr/one-or-more read-let-binding)
read-close-bracket
(grmr/one-or-more read-sub-expr)
read-close-paren)
(grmr/error "Invalid 'let' expression")))))
(def read-do
(grmr/rule "do"
(apply-to (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"
(apply-to ast/or-expr
read-open-paren
(grmr/ignore "or")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/one-or-more read-sub-expr)
(grmr/error "An 'or' expression must contain at least one clause."))
read-close-paren)))
(def read-and
(grmr/rule "and"
(apply-to ast/and-expr
read-open-paren
(grmr/ignore "and")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (grmr/one-or-more read-sub-expr)
(grmr/error "An 'and' expression must contain at least one clause."))
read-close-paren)))
(def read-either
(grmr/rule "either"
(apply-to ast/either-expr
read-open-paren
(grmr/ignore "either")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-expr
(grmr/any read-sub-expr
(grmr/error "Missing 'either' clause."))
read-close-paren)))
(def read-cond-val
(grmr/rule "cond-value"
(apply-to ast/cond-val-expr
read-sub-expr
read-sub-expr)))
(def read-cond
(grmr/rule "cond"
(apply-to ast/cond-expr
read-open-paren
(grmr/ignore "cond")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/one-or-more read-cond-val)
(grmr/any read-sub-expr
(grmr/error "Missing 'cond' default clause."))
read-close-paren)))
(def ListOrVect (any-of c/VectorConstraint
c/ListConstraint))
(defn set-items [c items]
(apo (fn [c]
(cond (instance? ListOrVect c)
(Left (.items c items))
(Right c)))
c))
(defn set-tail [c tail]
(apo (fn [c]
(cond (instance? ListOrVect c)
(Left (.tail-c c tail))
(Right c)))
c))
(defn assert-min-count [file-name line-number len]
;; TODO: what was I thinking doing it this way. (Actually, I know.)
(-> c/seq-constraint
(set-items (repeat len c/top-type))
(set-tail c/coll-of-any)
(c/update-path file-name line-number)))
(def read-min-count-assertion
(grmr/rule "assert-min-count"
(apply-to assert-min-count
read-open-paren
ignore-whitespace
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/ignore "min-count")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-integer
(grmr/error "The 'min-count' expression must contain an integer"
"which is the minium length the sequence must have."))
read-close-paren)))
(defn assert-max-value [file-name line-number max]
(-> c/int-constraint
(.max max)
(c/update-path file-name line-number)))
(def read-max-val-assertion
(grmr/rule "assert-max"
(apply-to assert-max-value
read-open-paren
ignore-whitespace
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/ignore "max")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-integer
(grmr/error "The 'max' expression must contain an integer maximum value."))
read-close-paren)))
(defn assert-min-value [file-name line-number min]
(-> c/int-constraint
(.min min)
(c/update-path file-name line-number)))
(def read-min-val-assertion
(grmr/rule "assert-min"
(apply-to assert-min-value
read-open-paren
ignore-whitespace
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/ignore "min")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-integer
(grmr/error "The 'min' expression must contain an integer minimum value."))
read-close-paren)))
(def read-sub-type
(grmr/recurse "type-expr"))
(defn assert-type [type-sym]
(-> (either (get c/core-type-constraints type-sym)
(c/ReifiedConstraint c/UnknownType {} (ast/untag type-sym) empty-list c/no-symbol ""))
(c/update-path (ast/file-name type-sym) (ast/line-number type-sym))))
(defn assert-map-of [key-type val-type]
(assert (instance? c/ValueConstraint key-type))
(assert (instance? c/ValueConstraint val-type))
(-> (cata (fn [c]
(cond (instance? c/HashMapConstraint c)
(-> c
(.keys-c key-type)
(.vals-c val-type))
c))
c/hashmap-constraint)
(c/update-path (ast/file-name key-type) (ast/line-number key-type))))
(def read-map-assertion
(grmr/rule "assert-map-of"
(apply-to assert-map-of
read-open-paren
ignore-whitespace
(grmr/ignore "map-of")
(grmr/ignore (grmr/one-or-more whitespace))
read-sub-type
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-sub-type
(grmr/error "The 'map-of' expression must contain one type expression"
"for the key values and one for the mapped values."))
read-close-paren)))
(def read-multi-type
(grmr/rule "multi-type"
(apply-to (fn [type-exprs]
(c/trim (reduce type-exprs c/top-type c/intersect)))
read-open-paren
ignore-whitespace
(grmr/ignore "all-of")
(grmr/any (grmr/one-or-more read-sub-type)
(grmr/error "The 'all-of' expression must contain at least one"
"type expression."))
read-close-paren)))
(defn make-any-of [file line type-exprs]
(assert (instance? (vector-of c/ValueConstraint) type-exprs))
(c/SumConstraint type-exprs
(list [file line])
(symbol "") ""))
(def read-sum-type
(grmr/rule "sum-type"
(apply-to make-any-of
read-open-paren
ignore-whitespace
(grmr/ignore "any-of")
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/any (grmr/one-or-more read-sub-type)
(grmr/error "The 'any-of' expression must contain at least one"
"type expression."))
read-close-paren)))
(def generic-assertions
{"vector-of" c/vect-constraint
"list-of" c/list-constraint
"maybe-of" c/maybe-constraint
"set-of" c/set-constraint
"agent-of" c/agent-constraint
"promise-of" c/promise-constraint
"sequence-of" c/seq-constraint
"function-returns" c/fn-constraint
})
(def read-generic-type
(grmr/rule "generic-type"
(apply-to (fn [base-string file line contents-type]
(-> (either (get generic-assertions base-string)
(fn [_]
(print-err "No generic type" (str "'" base-string "'")
"exists. At" file ": " line)
(abort)))
(c/intersect (c/CollectionOf contents-type empty-list c/no-symbol ""))
(c/update-path file line)))
read-open-paren
ignore-whitespace
(apply grmr/any (keys generic-assertions))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
read-sub-type
read-close-paren)))
(def read-type-expr
(grmr/recursive-rule "type-expr"
(grmr/any read-sum-type
read-multi-type
read-map-assertion
read-generic-type
read-min-count-assertion
read-min-val-assertion
read-max-val-assertion
(apply-to assert-type
ignore-whitespace
read-symbol))))
(def read-type-assertion
(grmr/rule "assertion-type"
(apply-to (fn [type-expr sym]
(c/update-sym type-expr (ast/untag sym)))
read-open-paren
ignore-whitespace
(grmr/ignore "instance?")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-type-expr
(grmr/error "Ivalid type expression"))
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-symbol
(grmr/error "Missing symbol to assert type of in assertion expression."))
read-close-paren)))
(def read-assert
(grmr/rule "assert"
(apply-to identity
read-open-paren
(grmr/ignore "assert")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-type-assertion
(grmr/error "Missing type assertion in 'assert' expression."))
read-close-paren)))
(def read-assert-result
(grmr/rule "assert-result"
(apply-to ast/result-expr
read-open-paren
(grmr/ignore "assert-result")
(grmr/ignore (grmr/one-or-more whitespace))
;; TODO: remove this when code formatter is ready
(grmr/ignore (grmr/optional read-symbol))
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any read-type-assertion
(grmr/error "Missing type assertion in 'assert-result' expression."))
read-close-paren)))
(def read-apply-to
(grmr/rule "apply-to"
(apply-to identity
(grmr/ignore "(")
ignore-whitespace
(grmr/ignore "apply-to")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (apply-to
(fn [fn ln f arg args]
(let [file-name (ast/file-name f)
line-number (ast/line-number f)
apply* (ast/tag 'apply file-name line-number)
wrap* (ast/tag 'wrap file-name line-number)
list (ast/tag 'list file-name line-number)]
(ast/let-expr
[(ast/binding-ast (ast/tag "#x" fn ln) arg)]
[(ast/call-expr
[apply*
(ast/call-expr [wrap* (ast/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
(grmr/any read-sub-expr
(grmr/error "An 'apply-to' expression must have at least"
"one parameter expression."))
(grmr/none-or-more read-sub-expr)
ignore-whitespace
read-close-paren)
(grmr/error "Invalid 'apply-to' form.")))))
(def read-inline
(grmr/rule "read-inline"
(apply-to identity
read-open-paren
(grmr/ignore "inline")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (apply-to (fn [file-name line-number lang return-type body]
(ast/inline-ast lang (either return-type
c/top-type)
body file-name line-number))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/any read-symbol
(grmr/error "An inline code expression must specify"
"the language of the code snippet."
"At this point, only 'C' is supported."))
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/optional
(apply-to identity
read-type-expr
(grmr/ignore (grmr/one-or-more whitespace))))
(grmr/any read-string
(grmr/error "The code to be inlined must be a"
"string literal."))
read-close-paren)
(grmr/error "Invalid inline expression.")))))
(def read-inline-body
(grmr/rule "read-inline-body"
(apply-to 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
(apply-to (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"
(apply-to (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)
(grmr/error "Body of function is wrong."))
ignore-whitespace)))
(def read-arities
(grmr/rule "arities"
(grmr/any (apply-to vector read-single-arity)
(apply-to (fn [doc arities]
(vec (map arities (fn [arity]
(.doc arity doc)))))
read-fn-doc
(grmr/one-or-more (apply-to identity
read-open-paren
read-single-arity
read-close-paren))))))
(def read-fn
(grmr/rule "fn"
(apply-to identity
read-open-paren
(grmr/ignore "fn")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (apply-to (fn [name arities]
(ast/fn-expr name arities))
(grmr/optional read-symbol)
ignore-whitespace
read-arities
read-close-paren)
(grmr/error "Invalid 'fn' expression.")))))
(def read-impl-arity
(grmr/rule "impl-arity"
(apply-to (fn [params doc body]
(ast/fn-arity params doc body))
(apply-to ast/params
ignore-whitespace
(grmr/ignore "[")
(grmr/one-or-more read-sub-dest)
(grmr/any (apply-to maybe read-var-arg)
(grmr/always nothing))
read-close-bracket)
read-fn-doc
(grmr/any read-inline-body
(grmr/one-or-more read-sub-expr)
(grmr/error "Body of function is wrong."))
ignore-whitespace)))
(def read-implementation
(grmr/rule "protocol-implementation"
(apply-to (fn [fn-sym arities]
{fn-sym (map arities (fn [arity]
(.fn-sym arity fn-sym)))})
read-open-paren
(grmr/any read-symbol
(grmr/error "A prototype function implementation must have a name."))
(apply-to vector read-impl-arity)
read-close-paren)))
(def read-proto-impls
(grmr/rule "protocol-implementations"
(grmr/any read-assert
(apply-to (fn [_] {})
read-block-comment)
(apply-to hash-map
ignore-whitespace
(grmr/any read-symbol
(grmr/all "(" (grmr/error "Missing protocol name in expression.")))
(apply-to (fn [impl-fns]
(apply merge-with (cons comp (seq impl-fns))))
(grmr/one-or-more read-implementation))))))
(def read-reify
(grmr/rule "reify"
(apply-to (fn [impls]
(ast/reified nothing impls))
read-open-paren
(grmr/ignore "reify")
(grmr/ignore (grmr/one-or-more whitespace))
(apply-to (fn [proto-impls]
(apply merge-with (cons comp (seq proto-impls))))
(grmr/one-or-more read-proto-impls))
read-close-paren)))
(def curr-file-name
(grmr/rule "_FILE_"
(apply-to (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_"
(apply-to identity
ignore-whitespace
(grmr/ignore "_LINE_")
(grmr/get-value 'line-number))))
(def read-vector
(grmr/rule "vector"
(apply-to identity
(grmr/ignore "[")
(apply-to (fn [fn ln elems]
(ast/call-expr (cons (ast/tag 'vector fn ln)
(seq elems))))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/none-or-more read-sub-expr)
read-close-bracket))))
(def read-hash-map
(grmr/rule "hash-map"
(apply-to identity
(grmr/ignore "{")
(apply-to (fn [fn ln elems]
(ast/call-expr (cons (ast/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 "}")
(grmr/error "Missing \"}\"."))))))
(def read-hash-set
(grmr/rule "hash-set"
(apply-to identity
(grmr/ignore "#{")
(apply-to (fn [fn ln elems]
(ast/call-expr (cons (ast/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 "}")
(grmr/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 (ast/tag 'vector (ast/file-name quoted-list)
(ast/line-number quoted-list))
(vec contents))))
(ast/call-ast (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 (ast/tag 'vector (ast/file-name quoted-vect) (ast/line-number quoted-vect))
contents)))
(ast/call-ast (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"
(apply-to identity
ignore-whitespace
(grmr/any (apply-to identity
read-open-paren
(grmr/none-or-more
(grmr/recurse "quoted-value"))
read-close-paren)
(apply-to (fn [xs]
(cons 'vector (seq xs)))
(grmr/ignore "[")
(grmr/one-or-more
(grmr/recurse "quoted-value"))
read-close-bracket)
read-integer-literal
read-string-literal
read-symbol)
ignore-whitespace)))
(def read-quoted
(grmr/rule "quoted"
(apply-to 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/cond-ast
[(ast/cond-val-ast clause body)]
(ast/call-ast (ast/tag 'zero fn ln)
[wrapper]))))
(nest-when-not [body clause wrapper]
(let [fn (ast/file-name clause)
ln (ast/line-number clause)]
(ast/cond-ast
[(ast/cond-val-ast clause (ast/call-ast (ast/tag 'zero fn ln)
[wrapper]))]
body)))
(nest-binding [body binding wrapper]))
(extend-type ast/let-ast
ForBinding
(nest-binding [body binding wrapper]
(ast/call-ast (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 (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/either-ast
ForBinding
(nest-binding [body binding wrapper]
(ast/call-ast (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/cond-ast
ForBinding
(nest-binding [body binding wrapper]
(ast/call-ast (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"
(apply-to (fn [bindings]
(ForLetExpr bindings))
ignore-whitespace
(grmr/ignore ":let")
(grmr/ignore (grmr/one-or-more whitespace))
read-open-bracket
(grmr/one-or-more read-let-binding)
read-close-bracket
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"
(apply-to (fn [clause]
(ForWhenExpr clause))
ignore-whitespace
(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"
(apply-to (fn [clause]
(ForWhenNotExpr clause))
ignore-whitespace
(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
(ast/tag 'flat-map fn ln)
[(ast/cond-ast [(ast/cond-val-ast clause (ast/call-ast (ast/tag 'wrap fn ln)
[wrapper body]))]
(ast/call-ast (ast/tag 'zero fn ln)
[wrapper]))
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(ast/tag "#x" fn ln)]) ""
[(ast/call-ast (ast/tag 'wrap fn ln)
[wrapper (ast/tag "#x" fn ln)])])])])))
(nest-when-not [_ clause wrapper]
(let [fn (ast/file-name clause)
ln (ast/line-number clause)]
(ast/call-ast
(ast/tag 'flat-map fn ln)
[(ast/cond-ast [(ast/cond-val-ast clause (ast/call-ast (ast/tag 'zero fn ln) [wrapper]))]
(ast/call-ast (ast/tag 'wrap fn ln) [wrapper body]))
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(ast/tag "#x" fn ln)]) ""
[(ast/call-ast (ast/tag 'wrap fn ln)
[wrapper (ast/tag "#x" fn ln)])])])])))
(nest-binding [_ binding wrapper]
(let [fn (ast/file-name binding)
ln (ast/line-number binding)]
(ast/call-ast (ast/tag 'map fn ln)
[(.val binding)
(ast/fn-expr nothing
[(ast/fn-arity (ast/params [(.binding binding)]) ""
[body])])])))
Stringable
(string-list [_] (comp (list "<ForResult ")
(string-list body)
(list ">"))))
(defn nest-for-exprs [bogus bindings body]
(let [wrapper (ast/tag "#wrapper"
(ast/file-name (.val bogus))
(ast/line-number (.val bogus)))]
(-> (list (ForLetExpr [(ast/binding wrapper (.val bogus))])
(ast/binding (.binding bogus) wrapper))
(comp (remove bindings (partial instance? ast/NoCode)))
reverse
(reduce (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
(apply-to identity
read-block-comment
ignore-whitespace))))
(def read-for
(grmr/rule "for"
(apply-to identity
read-open-paren
(grmr/ignore "for")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (apply-to nest-for-exprs
read-open-bracket
(grmr/any read-let-binding
(grmr/error "Invalid initial 'for' binding."))
(grmr/any (grmr/none-or-more read-for-binding)
(grmr/error "Invalid 'for' bindings."))
read-close-bracket
(grmr/any (grmr/any read-sub-expr
(grmr/error "The body of a 'for' expression"
" must have a single"
" expression in it."))
(grmr/error "Invalid 'for' body.")))
(grmr/error "Invalid 'for' expression."))
(grmr/any (grmr/ignore
(grmr/all read-sub-expr
(grmr/error "The body of a 'for'"
"expression may only have"
"one expression in it.")))
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 (apply-to identity
(grmr/any (apply-to ast/call-expr
(grmr/all read-symbol))
read-call)
ignore-whitespace)
read-block-comment)))
(def read-threading
(grmr/rule "->"
(apply-to identity
read-open-paren
(grmr/ignore "->")
(grmr/any (apply-to nest-thread-exprs
(grmr/any read-sub-expr
(grmr/error "A threading expression may not"
"be empty."))
(grmr/any (grmr/one-or-more read-thread-expr)
(grmr/error "A threading expression must have"
"at least one function call.")))
(grmr/error "Invalid '->' expression."))
read-close-paren)))
(def read-empty-list
(grmr/rule "empty-list"
(apply-to (fn [fn ln]
(ast/call-ast (ast/tag 'list fn ln) []))
(grmr/get-value 'file-name)
(grmr/get-value 'line-number)
(grmr/ignore "(")
ignore-whitespace
(grmr/ignore ")"))))
(def read-expr
(grmr/recursive-rule "expr"
(apply-to 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-cond
read-fn
read-let
read-do
read-apply-to
read-reify
read-vector
read-hash-map
read-hash-set
read-for
read-threading
read-assert
read-assert-result
read-empty-list
(grmr/all read-inline
(grmr/error "'inline' expressions not allowed here."))
read-call
read-block-comment)
ignore-whitespace)))
(def read-main
(grmr/rule "main"
(apply-to ast/annotated
read-open-paren
(grmr/ignore "main")
(grmr/any (apply-to ast/main-fn
read-list-destructure
(grmr/any read-inline-body
(grmr/one-or-more read-expr)
(grmr/error "Body of 'main' fn is wrong."))
read-close-paren)
(grmr/error "'main' fn expression is wrong.")))))
(def read-def
(grmr/rule "def"
(apply-to ast/annotated
read-open-paren
(grmr/ignore "def")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (apply-to (fn [sym value]
(ast/definition sym (list value)))
(grmr/any read-symbol
(grmr/error "'def' must be followed by the name"
"of the value being defined."))
ignore-whitespace
(grmr/any read-inline
read-sum-type
read-multi-type
read-map-assertion
read-generic-type
read-expr)
ignore-whitespace
read-close-paren)
(apply-to ast/declare
read-symbol
read-close-paren)
(grmr/error "Invalid 'def' expression.")))))
(def read-prototype
(grmr/rule "prototype"
(grmr/any read-assert
(apply-to identity
read-open-paren
(grmr/any
(apply-to ast/prototype
(grmr/any read-symbol
(grmr/error "Every prototype function must"
"have a unique name."))
read-list-destructure
read-fn-doc
(grmr/any read-inline-body
(grmr/none-or-more read-expr))
read-close-paren)
(grmr/error "Invalid prototype function."))))))
(def read-defprotocol
(grmr/rule "defprotocol"
(apply-to identity
read-open-paren
(grmr/ignore "defprotocol")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (apply-to
(fn [sym prototypes]
(ast/protocol
sym (remove prototypes (partial instance? ast/NoCode))))
(grmr/any read-symbol
(grmr/error "'defprotocol' must be followed by"
"the name of the protocol."))
;; TODO: much too complex. should be
;; (grmr/none-or-more read-prototype)
;; but this gives better error messages
(apply-to comp*
(grmr/none-or-more read-block-comment)
(grmr/all (grmr/any (grmr/one-or-more read-prototype)
(grmr/error "A protocol definition must"
"contain at least one"
"prototype function defintion."))
(grmr/none-or-more
(grmr/any read-prototype
read-block-comment))))
read-close-paren)
(grmr/error "Invalid 'defprotocol' expression.")))))
(def read-defn
(grmr/rule "defn"
(apply-to identity
read-open-paren
(grmr/ignore "defn")
(grmr/ignore (grmr/one-or-more whitespace))
(grmr/any (apply-to (fn [name arities]
(ast/definition name
(list (ast/fn-expr (maybe name)
arities))))
(grmr/any read-symbol
(grmr/error "'defn' must be followed by"
"the name of the function."))
(grmr/ignore (grmr/one-or-more whitespace))
read-arities
read-close-paren)
(grmr/error "Invalid 'defn' expression.")))))
(def read-extend-type
(grmr/rule "extend-type"
(apply-to identity
read-open-paren
(grmr/ignore "extend-type")
(grmr/any (apply-to ast/type-extension
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/any read-symbol
(grmr/error "'extend-type' must be followed by a"
"type name."))
(grmr/one-or-more read-proto-impls)
read-close-paren)
(grmr/error "Invalid 'extend-type' expression.")))))
(def read-deftype
(grmr/rule "deftype"
(apply-to identity
read-open-paren
(grmr/ignore "deftype")
(grmr/any (apply-to ast/type-expr
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/any read-symbol
(grmr/error "'deftype' must be followed by a"
"type name."))
(grmr/any read-list-destructure
(grmr/error "Fields (if any) for a new type must be"
"enclosed by square brackets [ ]."))
(grmr/none-or-more read-proto-impls)
read-close-paren)
(grmr/error "Invalid 'deftype' expression.")))))
(def read-JS-callable
(grmr/rule "JS-callable"
(apply-to identity
read-open-paren
(grmr/ignore "JS-callable")
(grmr/any (apply-to (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)
(grmr/error "invalid 'JS-callable' expression.")))))
(defn kw-string-arg [kw-sym]
(apply-to (fn [kw-sym value]
[(symbol kw-sym) value])
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/ignore ":")
(grmr/string-terminal kw-sym)
(grmr/ignore
(grmr/one-or-more whitespace))
read-string))
(def read-git-kwargs
(grmr/rule "git-kwargs"
(apply-to (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")
;; TODO: this error doesn't get triggered by
;; :sh "blahblah"
(grmr/all ":" (grmr/error "Invalid Git commit specifier.")))))))
(def read-git-dep-spec
(grmr/rule "git-dep"
(apply-to identity
read-open-paren
(grmr/ignore "git-dependency")
(grmr/any (apply-to ast/git-dep
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/any read-string
(grmr/error (str "Git repository URL must"
" be string literal.")))
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/any read-string
(grmr/error (str "File name in Git repository must"
" be string literal.")))
read-git-kwargs
read-close-paren)
(grmr/error "Invalid 'git-dependency' expression")))))
(def read-module-spec
(grmr/rule "module"
(apply-to identity
read-open-paren
(grmr/ignore "module")
(grmr/any (apply-to ast/module
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/any read-string
(grmr/error (str "Module file name must"
" be string literal.")))
read-close-paren)
(grmr/error "Invalid 'module' expression")))))
(defn output-error [error curr-state]
(either (or (for [file (get-in error [.state .values 'file-name])
line (get-in error [.state .values 'line-number])
expr-line (get-in curr-state [.values 'line-number])]
(do
(print-err (.val error) " At" (str file ":") (str line ".")
(cond (= line expr-line) ""
(str "\n In expression at line " (str expr-line "."))))))
(for [file (get-in error [.state .values 'file-name])
expr-line (get-in curr-state [.values 'line-number])]
(print-err (.val error) " At" (str file ":") (str expr-line "."))))
(print-err (.val error)))
error)
(def read-add-ns
(grmr/rule
"add-ns"
(apply-to identity
ignore-whitespace
(grmr/catch-error
output-error
(apply-to identity
read-open-paren
(grmr/ignore "add-ns")
(grmr/any (apply-to ast/ns-add
(grmr/ignore
(grmr/one-or-more whitespace))
(grmr/any read-symbol
(grmr/error "Missing or invalid namespace symbol"))
(grmr/any read-module-spec
read-git-dep-spec
(grmr/error "Missing or invalid namespace"
"specification"))
read-close-paren)
(grmr/error "Invalid 'add-ns' expression")))))))
(def bad-expr
(grmr/rule "bad-expr"
(grmr/all ignore-whitespace "("
(grmr/error "Invalid expression"))))
(def shebang (apply-to (fn [file]
;; just a dummy ast that does nothing
(ast/inline-ast (ast/tag 'C) c/top-type "" file 0))
(grmr/get-value 'file-name)
(grmr/ignore (grmr/all "#!"
(grmr/none-or-more not-eol)
newline))))
(def top-level
(grmr/recursive-rule "top-level"
(apply-to identity
ignore-whitespace
(grmr/catch-error
output-error
(grmr/any read-defn
read-def
read-defprotocol
read-deftype
read-extend-type
read-block-comment
read-main
read-JS-callable
read-inline
read-add-ns
shebang
bad-expr)))))