Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
586 lines (446 sloc) 16.1 KB
(add-ns c (git-dependency "https://github.com/Toccata-Lang/constraints.git"
"constraints.toc"
:sha "3435b1b"))
(def SymbolOrString (comp Symbol
String))
(defprotocol FileLineInfo
(file-name [ast]
(assert-result x (instance? SymbolOrString x))
"")
(line-number [ast]
0))
(extend-type List
FileLineInfo
(file-name [l]
(either (map (first l) file-name)
""))
(line-number [l]
(either (map (first l) line-number)
0)))
(extend-type Vector
FileLineInfo
(file-name [v]
(either (map (first v) file-name)
""))
(line-number [v]
(either (map (first v) line-number)
0)))
(extend-type HashMap
FileLineInfo
(file-name [m]
(file-name (seq m)))
(line-number [m]
(line-number (seq m))))
(deftype block-comment-ast [lines path-to-file line-num]
(assert (instance? Vector lines))
(assert (instance? SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_] (comp (list "<BlockCommentAST")
(interpose lines "\n")
(list ">")))
FileLineInfo
(file-name [_] path-to-file)
(line-number [_] line-num))
(defn block-comment [path-to-file line-num lines]
(block-comment-ast lines path-to-file line-num))
(deftype integer-ast [int path-to-file line-num]
(assert (instance? Integer int))
(assert (instance? SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_] (list (str int)))
FileLineInfo
(file-name [_] path-to-file)
(line-number [_] line-num))
(deftype string-ast [string path-to-file line-num]
(assert (instance? String string))
(assert (instance? SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_] (list "\"" string "\""))
FileLineInfo
(file-name [_] path-to-file)
(line-number [_] line-num))
(deftype inline-ast [lang result-type txt path-to-file line-num]
;; TODO
;; (assert (instance? Symbol lang))
(assert (instance? Maybe result-type))
(assert (instance? String txt))
(assert (instance? SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_]
(list "(inline " (str lang) " " (str (either result-type "")) " \"" txt "\")"))
FileLineInfo
(file-name [_] path-to-file)
(line-number [_] line-num))
(defn inline [lang txt result-type path-to-file line-num]
(inline-ast lang txt result-type path-to-file line-num))
(deftype params-ast [fixed variadic]
(assert (instance? Vector fixed))
(assert (instance? Maybe variadic))
Stringable
(string-list [_]
(comp (list "[")
(flat-map (interpose fixed " ") string-list)
(either (map variadic (fn [variadic]
(cons " & " (string-list variadic))))
empty-list)
(list "]")))
Collection
(count [_] (count fixed))
FileLineInfo
(file-name [_] (file-name fixed))
(line-number [_] (line-number fixed)))
(defn params
([fixed] (params-ast fixed nothing))
([fixed variadic] (params-ast fixed variadic)))
(deftype main-ast [params body]
(assert (instance? params-ast params))
(assert (instance? Vector body))
Stringable
(string-list [_] (comp (list "<MainAST ")
(string-list params)
(list " ")
(string-list body)
(list ">")))
FileLineInfo
(file-name [_] (file-name body))
(line-number [_] (line-number body)))
(defn main-fn [params body]
(main-ast params body))
(deftype declaration-ast [sym]
;; TODO
;; (assert (instance? Symbol sym))
Stringable
(string-list [_] (list "<DeclareAST " (str sym) ">"))
FileLineInfo
(file-name [_] (file-name sym))
(line-number [_] (line-number sym)))
(defn declare [sym]
(declaration-ast sym))
(deftype fn-arity-ast [fn-sym fn-var params doc body param-consts result-const]
(assert (instance? params-ast params))
(assert (instance? Vector body))
(assert (instance? Vector param-consts))
(assert (instance? c/ValueConstraint result-const))
Stringable
(string-list [_] (comp (list "(")
(string-list params)
(list "\n")
(flat-map (interpose body "\n") string-list)
(list ")")))
FileLineInfo
(file-name [_] (file-name body))
(line-number [_] (line-number body)))
(defn fn-arity [params doc body]
(fn-arity-ast "" "" params doc body [] c/top-type))
(deftype fn-ast [fn-sym arities]
(assert (instance? Maybe fn-sym))
(assert (instance? Vector arities))
Type
(type-name [x]
(str "fn-ast: " fn-sym))
Stringable
(string-list [_]
(comp (list "(fn " (str (either fn-sym "")) " ")
(flat-map (seq arities) string-list)
(list ")")))
FileLineInfo
(file-name [_] (file-name arities))
(line-number [_] (line-number arities)))
(defn fn-expr [sym arities]
(fn-ast sym arities))
(deftype call-ast [call-target args]
(assert (instance? Vector args))
Stringable
(string-list [_]
(comp (list "(" (str call-target) " ")
(flat-map (interpose (seq args) " ") string-list)
(list ")")))
FileLineInfo
(file-name [_] (file-name call-target))
(line-number [_] (line-number call-target)))
(defn call-expr [[target & args]]
(call-ast target (vec args)))
(def BindingTarget (comp Symbol
params-ast))
(deftype binding-ast [binding val]
;; TODO
;; (assert (instance? BindingTarget binding))
Stringable
(string-list [_]
(list (str binding) " " (str val) "\n"))
FileLineInfo
(file-name [_] (file-name binding))
(line-number [_] (line-number binding)))
(defn binding [binding val]
(binding-ast binding val))
(deftype let-ast [bindings body]
(assert (instance? Vector bindings))
(assert (instance? Vector body))
Stringable
(string-list [_]
(list "(let " (str bindings) "\n" (apply str (interpose body "\n")) ")"))
FileLineInfo
(file-name [_] (file-name body))
(line-number [_] (line-number body)))
(defn let-expr [bindings body]
(let-ast bindings body))
(deftype and-ast [clauses]
(assert (instance? Vector clauses))
(assert (min-count clauses 1))
Stringable
(string-list [_]
(comp (list "(and ")
(flat-map (interpose clauses "\n") string-list)
(list ")")))
FileLineInfo
(file-name [_] (extract (map (first clauses) file-name)))
(line-number [_] (extract (map (first clauses) line-number))))
(defn and-expr [clauses]
(and-ast clauses))
(deftype or-ast [clauses]
(assert (instance? Vector clauses))
Stringable
(string-list [_]
(comp (list "(or ")
(flat-map (seq clauses) string-list)
(list ")")))
FileLineInfo
(file-name [_] (extract (map (first clauses) file-name)))
(line-number [_] (extract (map (first clauses) line-number))))
(defn or-expr [clauses]
(or-ast clauses))
(deftype either-ast [clause alt]
Stringable
(string-list [_]
(comp (list "(either ")
(string-list clause)
(list "\n")
(string-list alt)
(list ")")))
FileLineInfo
(file-name [_] (file-name clause))
(line-number [_] (line-number clause)))
(defn either-expr [clause alt]
(either-ast clause alt))
(extend-type c/TypeConstraint
FileLineInfo
(file-name [c] (file-name (.type-sym c)))
(line-number [c] (line-number (.type-sym c))))
(defn assert-min-count [sym len]
(let [fn (file-name sym)]
;; TODO: what was I thinking doing it this way. (Actually, I know.)
(c/ItemsConstraint (repeat len c/top-type)
(list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number sym)])
(maybe sym)
"")))
(def MaybeType (inline C Integer "(Value *)&(Integer){IntegerType, -1, MaybeType};"))
(def VectorType (inline C Integer "(Value *)&(Integer){IntegerType, -1, VectorType};"))
(def ListType (inline C Integer "(Value *)&(Integer){IntegerType, -1, ListType};"))
(def BitmapIndexedType (inline C Integer "(Value *)&(Integer){IntegerType, -1, BitmapIndexedType};"))
(def ArrayNodeType (inline C Integer "(Value *)&(Integer){IntegerType, -1, ArrayNodeType};"))
(def HashCollisionNodeType (inline C Integer "(Value *)&(Integer){IntegerType, -1, HashCollisionNodeType};"))
(defn assert-vector-of [type-expr]
(let [fn (file-name type-expr)
path (list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number type-expr)])]
(c/MultiConstraint [(c/TypeConstraint {VectorType #{}} path 'Vector nothing "")
(c/InferredInner
(either (instance? c/SymbolConstraints type-expr)
(c/TypeConstraint {} path type-expr nothing ""))
empty-list nothing "")])))
(defn assert-list-of [type-expr]
(let [fn (file-name type-expr)
path (list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number type-expr)])]
(c/MultiConstraint [(c/TypeConstraint {ListType #{}} path 'List nothing "")
(c/InferredInner
(either (instance? c/SymbolConstraints type-expr)
(c/TypeConstraint {} path type-expr nothing ""))
empty-list nothing "")])))
(defn assert-maybe-of [type-expr]
(let [fn (file-name type-expr)
path (list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number type-expr)])]
(c/MultiConstraint [(c/TypeConstraint {MaybeType #{}} path 'Maybe nothing "")
(c/InferredInner
(either (instance? c/SymbolConstraints type-expr)
(c/TypeConstraint {} path type-expr nothing ""))
empty-list nothing "")])))
(defn assert-map-of [key-type val-type]
(let [fn (file-name key-type)
path (list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number key-type)])]
(c/MultiConstraint [(c/TypeConstraint {BitmapIndexedType #{}
ArrayNodeType #{}
HashCollisionNodeType #{}}
path 'HashMap nothing "")
;; TODO: add key constraint
(c/InferredInner
(either (instance? c/SymbolConstraints val-type)
(c/TypeConstraint {} path val-type nothing ""))
empty-list nothing "")])))
(defn assert-type [type-sym sym]
(either (map (instance? c/Constraints type-sym)
(fn [constraint]
(c/update-sym constraint sym)))
(let [fn (file-name type-sym)]
(c/TypeConstraint {} (list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number type-sym)])
type-sym (maybe sym) ""))))
(defn assert-max-value [max sym]
(let [fn (file-name sym)]
(c/MaxValue max (list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number sym)])
(maybe sym) "")))
(defn assert-min-value [min sym]
(let [fn (file-name sym)]
(c/MinValue min (list [(either (and (= fn 'core)
(maybe "$TOCCATA_DIR/core.toc"))
fn)
(line-number sym)])
(maybe sym) "")))
(defn result-expr [sym assertion]
;; TODO: no longer need 'sym'
(c/ResultConstraint assertion))
(deftype prototype-ast [fn-name params doc default-body]
(assert (instance? params-ast params))
(assert (instance? block-comment-ast doc))
(assert (instance? Vector default-body))
Stringable
(string-list [_] (list "<PrototypeFnAST " (str fn-name) ">"))
FileLineInfo
(file-name [_] (file-name fn-name))
(line-number [_] (line-number fn-name)))
(defn prototype [fn-name args doc default-body]
(prototype-ast fn-name args doc default-body))
(deftype protocol-ast [protocol-sym prototypes]
;; TODO
;; (assert (instance? Symbol protocol-sym))
(assert (instance? Vector prototypes))
Stringable
(string-list [_] (list "<ProtocolAST " (str protocol-sym) ">"))
FileLineInfo
(file-name [_] (file-name protocol-sym))
(line-number [_] (line-number protocol-sym)))
(defn protocol [sym prototypes]
(protocol-ast sym prototypes))
(deftype extend-ast [type impls]
;; TODO
;; (assert (instance? Symbol type))
(assert (instance? HashMap impls))
Stringable
(string-list [_] (list "<ExtendAST " (str type) ">"))
FileLineInfo
(file-name [_] (file-name type))
(line-number [_] (line-number type)))
(defn type-extension [type impls]
(extend-ast type (either (map (empty? impls) (fn [_] {}))
(apply comp (seq (filter impls (partial instance? HashMap)))))))
(deftype quoted-ast [q-val]
Stringable
(string-list [_]
(list "'" (str q-val)))
FileLineInfo
(file-name [_] (file-name q-val))
(line-number [_] (line-number q-val)))
(defn quoted [q-val]
(quoted-ast q-val))
(deftype reify-ast [type-num impls]
(assert (instance? Integer type-num))
(assert (instance? HashMap impls))
Stringable
(string-list [_] (list "<Reify>"))
FileLineInfo
(file-name [_] (file-name impls))
(line-number [_] (line-number impls)))
(defn reified [type-num impls]
(reify-ast type-num impls))
(deftype type-ast [sym fields impls]
;; TODO
;; (assert (instance? Symbol sym))
(assert (instance? params-ast fields))
(assert (instance? Vector impls))
Stringable
(string-list [_] (list "<TypeAST " (str sym) ">"))
FileLineInfo
(file-name [_] (file-name sym))
(line-number [_] (line-number sym)))
(defn type-expr [sym fields impls]
(type-ast sym fields impls))
(deftype module-ast [file-path]
(assert (instance? String file-path)))
(defn module [file-path]
(module-ast file-path))
(deftype git-dep-ast [repo file args]
(assert (instance? String repo))
(assert (instance? String file))
(assert (instance? HashMap args))
FileLineInfo
(file-name [_] (file-name repo))
(line-number [_] (line-number repo)))
(defn git-dep [repo file args]
(git-dep-ast repo file args))
(deftype add-ns-ast [ns-sym mod]
;; TODO
;; (assert (instance? Symbol ns-sym))
Stringable
(string-list [_] (list "<AddNS " (str ns-sym) ">"))
FileLineInfo
(file-name [_] (file-name ns-sym))
(line-number [_] (line-number ns-sym)))
(defn ns-add [ns mod]
(add-ns-ast ns mod))
(deftype definition-ast [sym value-exprs]
;; TODO
;; (assert (instance? Symbol sym))
Stringable
(string-list [_]
(comp (list "(def " (str sym) "\n")
(interpose (map value-exprs str) "\n")
(list ")")))
FileLineInfo
(file-name [_] (file-name sym))
(line-number [_] (line-number sym)))
(defn definition [sym value]
(definition-ast sym value))
(deftype JS-callable [sym num-args]
Stringable
(string-list [_]
(list "(JS-callable " (str sym) ", " (str num-args) ")"))
FileLineInfo
(file-name [_] (file-name sym))
(line-number [_] (line-number sym)))
(def CodeAST (comp inline-ast
let-ast
and-ast
or-ast
either-ast
quoted-ast
reify-ast
call-ast
fn-ast
Symbol
String
Integer))
(def NoCode (comp c/ResultConstraint
ast/block-comment-ast
c/SymbolConstraints))
You can’t perform that action at this time.