Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
;; TODO: make constraints a recursive type when possible
(add-ns c (git-dependency "https://github.com/Toccata-Lang/constraints.git"
"constraints.toc"
:sha "06343af"))
(defprotocol FileLineInfo
(file-name [ast]
(assert-result x (instance? c/SymbolOrString x))
"")
(line-number [ast]
0))
;; TODO: combine with FileLineInfo
(defprotocol FileLoc
(location [ast]
(c/Location (file-name ast) (line-number ast))))
(extend-type c/Location
FileLineInfo
(file-name [ast]
(assert-result x (instance? c/SymbolOrString x))
(.file ast))
(line-number [ast]
(.line ast)))
(deftype Annotated [ast annots]
Stringable
(string-list [_]
(list "^" (str ast)))
Container
(map [a f]
(.ast a (f ast)))
(map [a f embed]
(map (f ast) (partial .ast a)))
FileLineInfo
(file-name [_]
(file-name ast))
(line-number [_]
(line-number ast))
FileLoc
(location [_]
(c/Location (file-name ast) (line-number ast))))
(defn annotated [ast]
(Annotated ast 'annotations))
;; we tag symbols with file/line for use later
(defprotocol Tagged
(namespace [s]
(assert-result r (instance? (maybe-of Symbol) r)))
(tag [s]
(tag s "" 0))
(tag [s loc]
(assert (instance? c/Location loc))
(tag s (.file loc) (.line loc)))
(tag [s file line])
(untag [x]
(assert-result r (instance? Symbol r))))
(deftype tagged-symbol [ns base sym file line]
(assert (instance? c/SymbolOrString file))
(assert (instance? (maybe-of Symbol) ns))
(assert (instance? Symbol sym))
(assert (instance? Symbol base))
(assert (instance? Integer line))
FileLineInfo
(file-name [s] file)
(line-number [s] line)
Container
(map [x f]
x)
(map [x f embed]
(embed x))
Hashable
(sha1 [x] (sha1 base))
Ord
(<* [_ x] (<* x base))
Eq
(=* [_ x] (=* x base))
Stringable
(string-list [s]
(list (either (map (.ns s) (fn [ns-str] (str ns-str "/" (untag (.base s)))))
(str (untag (.base s))))))
Tagged
(namespace [s] (.ns s))
(tag [s] s)
(tag [s new-file new-line]
(tagged-symbol (.ns s) (.base s) (.sym s) new-file new-line))
(untag [s] (.base 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))))
(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 Sequence
FileLineInfo
(file-name [v]
(either (some v (fn [x]
(let [file (file-name x)]
(and (or (= file 'core)
(first file))
(maybe file)))))
""))
(line-number [v]
(either (some v (fn [x]
(let [file (file-name x)]
(and (or (= file 'core)
(first file))
(maybe (line-number x))))))
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-of String) lines))
(assert (instance? c/SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_] (comp (list "<BlockCommentAST")
(interpose lines "\n")
(list ">")))
Container
(map [x f]
x)
(map [x f embed]
(embed x))
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? c/SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_] (list (str int)))
Container
(map [x f]
x)
(map [x f embed]
(embed x))
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? c/SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_] (list "\"" string "\""))
Container
(map [x f]
x)
(map [x f embed]
(embed x))
FileLineInfo
(file-name [_] path-to-file)
(line-number [_] line-num))
(deftype inline-ast [lang result-type txt path-to-file line-num]
(assert (instance? tagged-symbol lang))
(assert (instance? c/ValueConstraint result-type))
(assert (instance? String txt))
(assert (instance? c/SymbolOrString path-to-file))
(assert (instance? Integer line-num))
Stringable
(string-list [_]
(list "(inline " (str lang) " " (str result-type) " \"" txt "\")"))
Container
(map [x f]
x)
(map [x f embed]
(embed x))
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? 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 "]")))
Container
(map [x f]
(params-ast (map fixed f) (map variadic f)))
(map [x f embed]
(either (map variadic (fn [var]
(for [new-fixed (map fixed f embed)
new-var (f var)]
(params-ast new-fixed (maybe new-var)))))
(map (map fixed f embed)
(fn [new-fixed]
(params-ast new-fixed nothing)))))
Tagged
(tag [_ file line]
(params-ast (map fixed (fn [x]
(tag x file line)))
(map variadic (fn [x]
(tag x file line)))))
Collection
(count [_] (count fixed))
FileLineInfo
(file-name [_] (file-name fixed))
(line-number [_] (line-number fixed)))
(def ParamType (any-of tagged-symbol
params-ast))
(defn params
([fixed] (params-ast fixed nothing))
([fixed variadic] (params-ast fixed variadic)))
(deftype main-ast [params body]
(assert (instance? Vector body))
Stringable
(string-list [_] (comp (list "<MainAST ")
(string-list params)
(list " ")
(string-list body)
(list ">")))
Container
(map [x f]
(main-ast (f params) (map body f)))
(map [x f embed]
(for [new-params (f params)
new-body (map body f embed)]
(main-ast new-params new-body)))
FileLineInfo
(file-name [_] (file-name body))
(line-number [_] (line-number body)))
(defn main-fn [params body]
(main-ast params body))
(deftype declaration-ast [sym]
(assert (instance? tagged-symbol sym))
Stringable
(string-list [_] (list "<DeclareAST " (str sym) ">"))
Container
(map [x f]
x)
(map [x f embed]
(embed x))
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? tagged-symbol fn-sym))
(assert (instance? c/ListConstraint param-consts))
(assert (instance? c/ValueConstraint result-const))
Stringable
(string-list [_] (comp (string-list params)
(list "\n")
(flat-map (interpose body "\n") string-list)))
;; (string-list [_]
;; (list "(ast/fn-arity-ast "
;; (str "'" fn-sym) " "
;; (str "'" fn-var) " "
;; (str params) "\n"
;; (str "\"" doc "\"") "\n"
;; (str body) " "
;; (str param-consts) " "
;; (str result-const)
;; ")"))
Container
(map [x f]
(-> x
(.params (map (f params) f))
(.body (map body f))))
(map [x f embed]
;; TODO: I think this should be (flat-map (f params) f)
(for [new-params (f params)
new-body (-> body
(map f embed))]
(-> x
(.params new-params)
(.body new-body))))
FileLineInfo
(file-name [_] (file-name body))
(line-number [_] (line-number body)))
(defn new-param-constraints [params]
(assert (instance? params-ast params))
(apo (fn [c]
(cond (or (instance? c/VectorConstraint c)
(instance? c/ListConstraint c))
(-> c
(.items (vec (repeat (count (.fixed params)) c/top-type)))
(.tail-c (cond (.variadic params)
c/coll-of-any
c/bottom-type))
(c/update-path (file-name params) (line-number params))
Left)
(Right c)))
c/seq-constraint))
(defn fn-arity
([params doc body]
(fn-arity (tag "") params doc body))
([fn-sym params doc body]
(fn-arity-ast fn-sym "" params doc body
(-> (new-param-constraints params)
.alts
(some (partial instance? c/ListConstraint))
extract)
c/top-type)))
(deftype fn-ast [fn-sym arities]
(assert (instance? (maybe-of tagged-symbol) fn-sym))
(assert (instance? Vector arities))
Type
(type-name [x]
(str "fn-ast: " fn-sym))
Stringable
(string-list [_]
(comp (list "(fn " (str (either (map fn-sym
(fn [s] (str s " ")))
"")))
(cond (= 1 (count arities))
(flat-map (seq arities) string-list)
(-> (seq arities)
(interpose "\n")
(flat-map (fn [arity]
(comp (list "(")
(string-list arity)
(list ")"))))))
(list ")")))
Container
(map [x f]
(fn-ast fn-sym (map arities f)))
(map [x f embed]
(-> arities
(map f embed)
(map (fn [new-arities]
(fn-ast fn-sym new-arities)))))
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 ")")))
Container
(map [x f]
(call-ast (f call-target) (map args f)))
(map [x f embed]
(for [new-target (f call-target)
new-args (map args f embed)]
(call-ast new-target new-args)))
FileLineInfo
(file-name [_]
(cond (first args)
(file-name args)
(file-name call-target)))
(line-number [_]
(cond (first args)
(line-number args)
(line-number call-target))))
(defn call-expr [[target & args]]
(call-ast target (vec args)))
(def BindingTarget (any-of tagged-symbol
params-ast))
(deftype binding-ast [binding val]
Stringable
(string-list [_]
(list (str binding) " " (str val)))
Container
(map [x f]
(binding-ast (f binding) (f val)))
(map [x f embed]
(for [new-val (f val)
new-binding (f binding)]
(binding-ast new-binding new-val)))
FileLineInfo
(file-name [_] (file-name val))
(line-number [_] (line-number val)))
(defn binding [binding val]
(binding-ast binding val))
(deftype let-ast [bindings body]
(assert (instance? (vector-of binding-ast) bindings))
(assert (instance? Vector body))
Stringable
(string-list [_]
(list "(let [" (to-str (interpose bindings "\n")) "]\n" (apply str (interpose body "\n")) ")"))
Container
(map [x f]
(let-ast (map bindings f) (map body f)))
(map [x f embed]
(for [new-bindings (map bindings f embed)
new-body (map body f embed)]
(let-ast new-bindings new-body)))
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? (all-of (min-count 1)
Vector)
clauses))
Stringable
(string-list [_]
(comp (list "(and ")
(flat-map (interpose clauses "\n") string-list)
(list ")")))
Container
(map [x f]
(and-ast (map clauses f)))
(map [x f embed]
(map (map clauses f embed)
and-ast))
FileLoc
(location [_] (extract (map (first clauses) location)))
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 ")")))
Container
(map [x f]
(or-ast (map clauses f)))
(map [x f embed]
(map (map clauses f embed)
or-ast))
FileLoc
(location [_] (extract (map (first clauses) location)))
FileLineInfo
(file-name [_] (extract (map (first clauses) file-name)))
(line-number [_] (extract (map (first clauses) line-number))))
(defn or-expr [clauses]
(or-ast clauses))
;; TODO: make threading into either, and, or possible
(deftype either-ast [clause alt]
Stringable
(string-list [_]
(comp (list "(either ")
(string-list clause)
(list "\n")
(string-list alt)
(list ")")))
Container
(map [x f]
(either-ast (f clause) (f alt)))
(map [x f embed]
(for [new-clause (f clause)
new-alt (f alt)]
(either-ast new-clause new-alt)))
FileLineInfo
(file-name [_] (file-name clause))
(line-number [_] (line-number clause)))
(defn either-expr [clause alt]
(either-ast clause alt))
(defn file-name-from-path [path]
(map (last path)
(fn [[file]] file)))
(defn line-number-from-path [path]
(map (last path)
(fn [[_ ln]] ln)))
(extend-type c/NoValues
FileLineInfo
(file-name [c] (file-name (.constraints c)))
(line-number [c] (line-number (.constraints c))))
(extend-type c/InferredInner
FileLineInfo
(file-name [c]
(either (file-name-from-path (.path c))
(file-name (.contents c))))
(line-number [c]
(either (line-number-from-path (.path c))
(line-number (.contents c)))))
(extend-type c/CollectionOf
FileLineInfo
(file-name [c]
(either (file-name-from-path (.path c))
(file-name (.contents c))))
(line-number [c]
(either (line-number-from-path (.path c))
(line-number (.contents c)))))
(extend-type c/VectorConstraint
FileLineInfo
(file-name [c]
(either (file-name-from-path (.path c))
(file-name (.items c))))
(line-number [c]
(either (line-number-from-path (.path c))
(line-number (.items c)))))
(extend-type c/ListConstraint
FileLineInfo
(file-name [c]
(either (file-name-from-path (.path c))
(file-name (.items c))))
(line-number [c]
(either (line-number-from-path (.path c))
(line-number (.items c)))))
(extend-type c/SumConstraint
FileLineInfo
(file-name [c]
(either (file-name-from-path (.path c))
(file-name (.alts c))))
(line-number [c]
(either (line-number-from-path (.path c))
(line-number (.alts c)))))
(extend-type c/ResultConstraint
FileLineInfo
(file-name [c]
(file-name (.assertion c)))
(line-number [c]
(line-number (.assertion c))))
(defn result-expr [assertion]
(c/ResultConstraint assertion))
(deftype prototype-ast [fn-name params doc default-body param-consts result-const]
(assert (instance? tagged-symbol fn-name))
(assert (instance? params-ast params))
(assert (instance? block-comment-ast doc))
(assert (instance? Vector default-body))
(assert (instance? c/ListConstraint param-consts))
Stringable
(string-list [_] (comp (list "(" (str fn-name) " ")
(string-list params)
(list "\n")
(flat-map (interpose default-body "\n") string-list)
")"))
Container
(map [x f]
(-> x
(.params (map params f))
(.default-body (map default-body f))))
(map [x f embed]
(for [new-params (map params f embed)
new-body (map default-body f embed)]
(-> x
(.params new-params)
(.default-body new-body))))
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
(-> (new-param-constraints args)
.alts
(some (partial instance? c/ListConstraint))
extract)
c/top-type))
(deftype protocol-ast [protocol-sym prototypes]
(assert (instance? tagged-symbol protocol-sym))
(assert (instance? Vector prototypes))
Stringable
(string-list [_] (list "(defprotocol " (str protocol-sym) "\n"
(to-str (interpose prototypes "\n"))
")"))
Container
(map [x f]
(.prototypes x (map prototypes f)))
(map [x f embed]
(map (map prototypes f embed)
(partial .prototypes x)))
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]
(assert (instance? tagged-symbol type))
(assert (instance? HashMap impls))
Stringable
(string-list [_] (list "(extend-type " (str type)
"\n" (to-str (interpose impls "\n"))
")"))
Container
(map [x f]
(.impls x (map-vals impls (fn [impl-fns]
(map-vals impl-fns (fn [arities]
(map arities f)))))))
(map [x f embed]
(map (contextual-map-vals impls (fn [impl-fns]
(contextual-map-vals impl-fns
(fn [arities]
(map arities f embed))
embed))
embed)
(partial .impls x)))
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)))
Ord
(<* [x y]
(assert (instance? quoted-ast y))
(and (< q-val (.q-val x))
(maybe x)))
Container
(map [x f]
(quoted-ast (f q-val)))
(map [x f embed]
(map (f q-val)
quoted-ast))
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? (maybe-of Integer) type-num))
(assert (instance? HashMap impls))
Stringable
(string-list [_] (list "(reify " (str type-num " \n" impls) ")"))
Container
(map [x f]
(.impls x (map-vals impls (fn [impl-fns]
(map-vals impl-fns (fn [arities]
(map arities f)))))))
(map [x f embed]
(map (contextual-map-vals impls (fn [impl-fns]
(contextual-map-vals impl-fns
(fn [arities]
(map arities f embed))
embed))
embed)
(partial .impls x)))
FileLineInfo
(file-name [_] (file-name impls))
(line-number [_] (line-number impls)))
(defn reified [type-num impls]
(reify-ast type-num impls))
(deftype cond-val-ast [conditional value]
Stringable
(string-list [_]
(list (str conditional " " value)))
Container
(map [x f]
(cond-val-ast (f conditional) (f value)))
(map [x f embed]
(for [new-cond (f conditional)
new-value (f value)]
(cond-val-ast new-cond new-value)))
FileLineInfo
(file-name [ast]
(file-name conditional))
(line-number [ast]
(line-number conditional)))
(defn cond-val-expr [conditional value]
(cond-val-ast conditional value))
(deftype cond-ast [conditionals default]
(assert (instance? (min-count 1) conditionals))
Stringable
(string-list [_]
(list "(cond " (to-str (flat-map conditionals (fn [c-v]
[(str c-v) "\n"])))
(str default) ")\n"))
Container
(map [x f]
(cond-ast (map conditionals f) (f default)))
(map [x f embed]
(for [new-conds (map conditionals f embed)
new-default (f default)]
(cond-ast new-conds new-default)))
FileLineInfo
(file-name [ast]
(file-name conditionals))
(line-number [ast]
(line-number conditionals)))
(defn cond-expr [conditionals default]
(cond-ast conditionals default))
(deftype type-ast [sym fields impls]
(assert (instance? tagged-symbol sym))
(assert (instance? params-ast fields))
(assert (instance? Vector impls))
Stringable
(string-list [_] (list "<TypeAST " (str sym) ">"))
Container
(map [x f]
(-> x
(.fields (map fields f))
(.impls (map impls
(fn [proto-map]
(map-vals proto-map
(fn [impls-map]
(map-vals impls-map f))))))))
(map [x f embed]
(for [new-fields (map fields f embed)
new-impls (map impls
(fn [proto-map]
(contextual-map-vals proto-map
(fn [impls-map]
(contextual-map-vals impls-map
(fn [arity-vec]
(map arity-vec f embed))
embed))
embed))
embed)]
(-> x
(.fields new-fields)
(.impls new-impls))))
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))
Container
(map [x f]
x)
(map [x f embed]
(embed x)))
(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))
Container
(map [x f]
x)
(map [x f embed]
(embed x))
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]
(assert (instance? tagged-symbol ns-sym))
Stringable
(string-list [_] (list "<AddNS " (str ns-sym) ">"))
Container
(map [x f]
(add-ns-ast ns-sym (f mod)))
(map [x f embed]
(map (f mod)
(partial add-ns-ast 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]
(assert (instance? tagged-symbol sym))
Stringable
(string-list [_]
(comp (list "(def " (str sym) "\n")
(interpose (map value-exprs str) "\n")
(list ")")))
Container
(map [x f]
(definition-ast sym (map value-exprs f)))
(map [x f embed]
(map (map (vec value-exprs) f embed)
(partial definition-ast sym)))
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) ")"))
Container
(map [x f]
x)
(map [x f embed]
(embed x))
FileLineInfo
(file-name [_] (file-name sym))
(line-number [_] (line-number sym)))
(defprotocol IsCode
(generates-code? [x]))
(extend-type Annotated
IsCode
(generates-code? [a]
(generates-code? (.ast a))))
(def CodeAST (any-of inline-ast
let-ast
and-ast
or-ast
either-ast
quoted-ast
reify-ast
call-ast
fn-ast
string-ast
integer-ast
tagged-symbol
cond-ast
Symbol
String
Integer))
(extend-type CodeAST
IsCode
(generates-code? [ast]
(maybe ast)))
(def NoCode (any-of c/ResultConstraint
block-comment-ast
c/ValueConstraint))
(extend-type NoCode
IsCode
(generates-code? [_]
nothing))