clj -> cljc
This commit is contained in:
parent
b277a1bf2a
commit
214e94465d
22
src/ludus/analyzer.cljc
Normal file
22
src/ludus/analyzer.cljc
Normal file
|
@ -0,0 +1,22 @@
|
||||||
|
(ns ludus.analyzer
|
||||||
|
(:require
|
||||||
|
[ludus.ast :as ast]
|
||||||
|
[ludus.token :as token]))
|
||||||
|
|
||||||
|
(defn analyze [ast] ast)
|
||||||
|
|
||||||
|
(comment "
|
||||||
|
Here's where we do a bunch of static analysis.
|
||||||
|
Some things we might wish for:
|
||||||
|
* No unused bindings
|
||||||
|
* No unbound names
|
||||||
|
* Compound `loop` and `gen` forms must have LHS's (tuple patterns) of the same length
|
||||||
|
* Recur must be in tail position in `loop`s
|
||||||
|
* Tail call optimization for simple recursion (rewrite it as a loop?)
|
||||||
|
* Check arities for statically known functions
|
||||||
|
* Enforce single-member tuple after called keywords
|
||||||
|
* Placeholders may only appear in tuples in synthetic expressions
|
||||||
|
* Each of these may have zero or one placeholders
|
||||||
|
* Function arities are correct
|
||||||
|
* Arity of called keywords must be 1
|
||||||
|
")
|
2
src/ludus/ast.cljc
Normal file
2
src/ludus/ast.cljc
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
(ns ludus.ast)
|
||||||
|
|
1
src/ludus/collections.cljc
Normal file
1
src/ludus/collections.cljc
Normal file
|
@ -0,0 +1 @@
|
||||||
|
(ns ludus.collections)
|
33
src/ludus/core.cljc
Normal file
33
src/ludus/core.cljc
Normal file
|
@ -0,0 +1,33 @@
|
||||||
|
(ns ludus.core
|
||||||
|
"A tree-walk interpreter for the Ludus language."
|
||||||
|
(:require
|
||||||
|
[ludus.scanner :as scanner]
|
||||||
|
[ludus.parser :as parser]
|
||||||
|
[ludus.interpreter :as interpreter]
|
||||||
|
[ludus.show :as show]
|
||||||
|
[clojure.pprint :as pp])
|
||||||
|
(:gen-class))
|
||||||
|
|
||||||
|
(defn- run [source]
|
||||||
|
(let [scanned (scanner/scan source)]
|
||||||
|
(if (not-empty (:errors scanned))
|
||||||
|
(do
|
||||||
|
(println "I found some scanning errors!")
|
||||||
|
(pp/pprint (:errors scanned))
|
||||||
|
(System/exit 65))
|
||||||
|
(let [parsed (parser/parse scanned)]
|
||||||
|
(if (not-empty (:errors parsed))
|
||||||
|
(do
|
||||||
|
(println "I found some parsing errors!")
|
||||||
|
(pp/pprint (:errors parsed))
|
||||||
|
(System/exit 66))
|
||||||
|
(let [interpreted (interpreter/interpret parsed)]
|
||||||
|
(println (show/show interpreted))
|
||||||
|
(System/exit 0)))))))
|
||||||
|
|
||||||
|
(defn -main [& args]
|
||||||
|
(cond
|
||||||
|
(= (count args) 1) (run (slurp (first args)))
|
||||||
|
:else (do
|
||||||
|
(println "Usage: ludus [script]")
|
||||||
|
(System/exit 64))))
|
1
src/ludus/data.cljc
Normal file
1
src/ludus/data.cljc
Normal file
|
@ -0,0 +1 @@
|
||||||
|
(ns ludus.data)
|
394
src/ludus/interpreter.cljc
Normal file
394
src/ludus/interpreter.cljc
Normal file
|
@ -0,0 +1,394 @@
|
||||||
|
(ns ludus.interpreter
|
||||||
|
(:require
|
||||||
|
[ludus.parser :as parser]
|
||||||
|
[ludus.scanner :as scanner]
|
||||||
|
[ludus.ast :as ast]
|
||||||
|
[ludus.prelude :as prelude]
|
||||||
|
[ludus.data :as data]
|
||||||
|
[clojure.pprint :as pp]))
|
||||||
|
|
||||||
|
;; right now this is not very efficient:
|
||||||
|
;; it's got runtime checking
|
||||||
|
;; we should be able to do these checks statically
|
||||||
|
;; that's for later, tho
|
||||||
|
(defn- resolve-word[word ctx-vol]
|
||||||
|
(let [ctx @ctx-vol]
|
||||||
|
(if (contains? ctx word)
|
||||||
|
(get ctx word)
|
||||||
|
(if (contains? ctx ::parent)
|
||||||
|
(recur word (::parent ctx))
|
||||||
|
(throw (ex-info (str "Unbound name: " word) {}))))))
|
||||||
|
|
||||||
|
(declare interpret-ast match interpret)
|
||||||
|
|
||||||
|
(defn- match-tuple [pattern value ctx-vol]
|
||||||
|
(cond
|
||||||
|
(not (vector? value)) {:success false :reason "Could not match non-tuple value to tuple"}
|
||||||
|
|
||||||
|
(not (= ::data/tuple (first value))) {:success false :reason "Could not match list to tuple"}
|
||||||
|
|
||||||
|
(not (= (:length pattern) (dec (count value))))
|
||||||
|
{:success false :reason "Cannot match tuples of different lengths"}
|
||||||
|
|
||||||
|
(= 0 (:length pattern) (dec (count value))) {:success true :ctx {}}
|
||||||
|
|
||||||
|
:else (let [members (:members pattern)]
|
||||||
|
(loop [i (:length pattern)
|
||||||
|
ctx {}]
|
||||||
|
(if (= 0 i)
|
||||||
|
{:success true :ctx ctx}
|
||||||
|
(let [match? (match (nth members (dec i)) (nth value i) ctx-vol)]
|
||||||
|
(if (:success match?)
|
||||||
|
(recur (dec i) (merge ctx (:ctx match?)))
|
||||||
|
{:success false :reason (str "Could not match " pattern " with " value)})))))))
|
||||||
|
|
||||||
|
(defn- match [pattern value ctx-vol]
|
||||||
|
(let [ctx @ctx-vol]
|
||||||
|
(case (::ast/type pattern)
|
||||||
|
::ast/placeholder {:success true :ctx {}}
|
||||||
|
|
||||||
|
::ast/atom
|
||||||
|
(let [match-value (:value pattern)]
|
||||||
|
(if (= match-value value)
|
||||||
|
{:success true :ctx {}}
|
||||||
|
{:success false
|
||||||
|
:reason (str "No match: Could not match " match-value " with " value)}))
|
||||||
|
|
||||||
|
::ast/word
|
||||||
|
(let [word (:word pattern)]
|
||||||
|
(if (contains? ctx word)
|
||||||
|
{:success false :reason (str "Name " word " is already bound")}
|
||||||
|
{:success true :ctx {word value}}))
|
||||||
|
|
||||||
|
::ast/tuple (match-tuple pattern value ctx-vol)
|
||||||
|
|
||||||
|
(throw (ex-info "Unknown pattern" {:pattern pattern})))))
|
||||||
|
|
||||||
|
(defn- update-ctx [ctx new-ctx]
|
||||||
|
(merge ctx new-ctx))
|
||||||
|
|
||||||
|
;; TODO: get "if let" pattern working
|
||||||
|
;; TODO: get typed exceptions to distinguish panics
|
||||||
|
(defn- interpret-let [ast ctx]
|
||||||
|
(let [pattern (:pattern ast)
|
||||||
|
expr (:expr ast)
|
||||||
|
value (interpret-ast expr ctx)
|
||||||
|
match (match pattern value ctx)
|
||||||
|
success (:success match)]
|
||||||
|
(if success
|
||||||
|
(vswap! ctx update-ctx (:ctx match))
|
||||||
|
(throw (ex-info (:reason match) {})))
|
||||||
|
value))
|
||||||
|
|
||||||
|
(defn- interpret-if [ast ctx]
|
||||||
|
(let [if-expr (:if ast)
|
||||||
|
then-expr (:then ast)
|
||||||
|
else-expr (:else ast)
|
||||||
|
if-value (interpret-ast if-expr ctx)]
|
||||||
|
(if if-value
|
||||||
|
(interpret-ast then-expr ctx)
|
||||||
|
(interpret-ast else-expr ctx))))
|
||||||
|
|
||||||
|
(defn- interpret-match [ast ctx]
|
||||||
|
(let [match-expr (:expr ast)
|
||||||
|
expr (interpret-ast match-expr ctx)
|
||||||
|
clauses (:clauses ast)]
|
||||||
|
(loop [clause (first clauses)
|
||||||
|
clauses (rest clauses)]
|
||||||
|
(if clause
|
||||||
|
(let [pattern (:pattern clause)
|
||||||
|
body (:body clause)
|
||||||
|
new-ctx (volatile! {::parent ctx})
|
||||||
|
match? (match pattern expr new-ctx)
|
||||||
|
success (:success match?)
|
||||||
|
clause-ctx (:ctx match?)]
|
||||||
|
(if success
|
||||||
|
(do
|
||||||
|
(vswap! new-ctx #(merge % clause-ctx))
|
||||||
|
(interpret-ast body new-ctx))
|
||||||
|
(recur (first clauses) (rest clauses))))
|
||||||
|
(throw (ex-info "Match Error: No match found" {}))))))
|
||||||
|
|
||||||
|
(defn- interpret-cond [ast ctx]
|
||||||
|
(let [clauses (:clauses ast)]
|
||||||
|
(loop [clause (first clauses)
|
||||||
|
clauses (rest clauses)]
|
||||||
|
(if (not clause)
|
||||||
|
(throw (ex-info "Cond Error: No match found" {}))
|
||||||
|
(let [test-expr (:test clause)
|
||||||
|
body (:body clause)
|
||||||
|
truthy? (boolean (interpret-ast test-expr ctx))]
|
||||||
|
(if truthy?
|
||||||
|
(interpret-ast body ctx)
|
||||||
|
(recur (first clauses) (rest clauses))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)))
|
||||||
|
|
||||||
|
(defn- interpret-called-kw [kw tuple ctx]
|
||||||
|
;; TODO: check this statically
|
||||||
|
(if (not (= 1 (:length tuple)))
|
||||||
|
(throw (ex-info "Called keywords must be unary" {}))
|
||||||
|
(let [kw (interpret-ast kw ctx)
|
||||||
|
map (second (interpret-ast tuple ctx))]
|
||||||
|
(if (::data/struct map)
|
||||||
|
(if (contains? map kw)
|
||||||
|
(kw map)
|
||||||
|
(if (= (::data/type map) ::data/ns)
|
||||||
|
(throw (ex-info (str "Namespace error: no member " kw " in ns " (::data/name map)) {}))
|
||||||
|
(throw (ex-info (str "Struct error: no member at " kw) {}))))
|
||||||
|
(get map kw))
|
||||||
|
)))
|
||||||
|
|
||||||
|
(defn- call-fn [lfn tuple ctx]
|
||||||
|
(cond
|
||||||
|
(= ::data/partial (first tuple))
|
||||||
|
{::data/type ::data/clj
|
||||||
|
:name (str (:name lfn) "{partial}")
|
||||||
|
:body (fn [arg]
|
||||||
|
(call-fn
|
||||||
|
lfn
|
||||||
|
(concat [::data/tuple] (replace {::data/placeholder arg} (rest tuple)))
|
||||||
|
ctx))}
|
||||||
|
|
||||||
|
(= (::data/type lfn) ::data/clj) (apply (:body lfn) (next tuple))
|
||||||
|
|
||||||
|
(= (::data/type lfn) ::data/fn)
|
||||||
|
(let [clauses (:clauses lfn)]
|
||||||
|
(loop [clause (first clauses)
|
||||||
|
clauses (rest clauses)]
|
||||||
|
(if clause
|
||||||
|
(let [pattern (:pattern clause)
|
||||||
|
body (:body clause)
|
||||||
|
new-ctx (volatile! {::parent ctx})
|
||||||
|
match? (match pattern tuple new-ctx)
|
||||||
|
success (:success match?)
|
||||||
|
clause-ctx (:ctx match?)]
|
||||||
|
(if success
|
||||||
|
(do
|
||||||
|
(vswap! new-ctx #(merge % clause-ctx))
|
||||||
|
(interpret-ast body new-ctx))
|
||||||
|
(recur (first clauses) (rest clauses))))
|
||||||
|
|
||||||
|
(throw (ex-info "Match Error: No match found" {:fn-name (:name lfn)})))))
|
||||||
|
|
||||||
|
(keyword? lfn)
|
||||||
|
(if (= 2 (count tuple))
|
||||||
|
(let [target (second tuple) kw lfn]
|
||||||
|
(if (::data/struct target)
|
||||||
|
(if (contains? target kw)
|
||||||
|
(kw target)
|
||||||
|
(if (= (::data/type target) ::data/ns)
|
||||||
|
(throw (ex-info (str "Namespace error: no member " kw " in ns" (::data/name target)) {}))
|
||||||
|
(throw (ex-info (str "Struct error: no member at " kw) {}))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
(kw target)))
|
||||||
|
(throw (ex-info "Called keywords take a single argument" {})))
|
||||||
|
|
||||||
|
:else (throw (ex-info "I don't know how to call that" {:fn lfn}))))
|
||||||
|
|
||||||
|
(defn- interpret-synthetic-term [prev-value curr ctx]
|
||||||
|
(let [type (::ast/type curr)]
|
||||||
|
(if (= type ::ast/atom)
|
||||||
|
(if (::data/struct prev-value)
|
||||||
|
(if (contains? prev-value (:value curr))
|
||||||
|
(get prev-value (:value curr))
|
||||||
|
(if (= (::data/type prev-value) ::data/ns)
|
||||||
|
(throw (ex-info (str "Namespace error: no member " (:value curr) " in ns " (::data/name prev-value)) {}))
|
||||||
|
(throw (ex-info (str "Struct error: no member " (:value curr)) {}))))
|
||||||
|
(get prev-value (:value curr)))
|
||||||
|
(call-fn prev-value (interpret-ast curr ctx) ctx))))
|
||||||
|
|
||||||
|
(defn- interpret-synthetic [ast ctx]
|
||||||
|
(let [terms (:terms ast)
|
||||||
|
first (first terms)
|
||||||
|
second (second terms)
|
||||||
|
rest (rest (rest terms))
|
||||||
|
first-term-type (::ast/type first)
|
||||||
|
first-val (if (= first-term-type ::ast/atom)
|
||||||
|
(interpret-called-kw first second ctx)
|
||||||
|
(interpret-synthetic-term (interpret-ast first ctx) second ctx))]
|
||||||
|
(reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)))
|
||||||
|
|
||||||
|
(defn- interpret-fn [ast ctx]
|
||||||
|
(let [name (:name ast)
|
||||||
|
clauses (:clauses ast)]
|
||||||
|
(if (= name ::ast/anon)
|
||||||
|
{::data/type ::data/fn
|
||||||
|
:name name
|
||||||
|
:clauses clauses}
|
||||||
|
(let [fn {::data/type ::data/fn
|
||||||
|
:name name
|
||||||
|
:clauses clauses}]
|
||||||
|
(if (contains? @ctx name)
|
||||||
|
(throw (ex-info (str "Name " name " is already bound") {}))
|
||||||
|
(do
|
||||||
|
(vswap! ctx update-ctx {name fn})
|
||||||
|
fn))))))
|
||||||
|
|
||||||
|
(defn- interpret-do [ast ctx]
|
||||||
|
(let [exprs (:exprs ast)
|
||||||
|
origin (interpret-ast (first exprs) ctx)
|
||||||
|
fns (rest exprs)]
|
||||||
|
(reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) origin fns)))
|
||||||
|
|
||||||
|
(defn- map-values [f]
|
||||||
|
(map (fn [kv]
|
||||||
|
(let [[k v] kv]
|
||||||
|
[k (f v)]))))
|
||||||
|
|
||||||
|
(defn- interpret-ns [ast ctx]
|
||||||
|
(let [members (:members ast)
|
||||||
|
name (:name ast)]
|
||||||
|
(if (contains? @ctx name)
|
||||||
|
(throw (ex-info (str "ns name " name " is already bound") {}))
|
||||||
|
(let [ns (into
|
||||||
|
{::data/struct true ::data/type ::data/ns ::data/name name}
|
||||||
|
(map-values #(interpret-ast % ctx))
|
||||||
|
members)]
|
||||||
|
(do
|
||||||
|
(vswap! ctx update-ctx {name ns})
|
||||||
|
ns)))))
|
||||||
|
|
||||||
|
(defn- interpret-import [ast ctx]
|
||||||
|
(let [path (:path ast)
|
||||||
|
name (:name ast)]
|
||||||
|
(if (contains? @ctx name)
|
||||||
|
(throw (ex-info (str "Name " name " is alrady bound") {}))
|
||||||
|
(let [result ;; TODO: add any error handling at all
|
||||||
|
(-> path
|
||||||
|
(slurp)
|
||||||
|
(scanner/scan)
|
||||||
|
(parser/parse)
|
||||||
|
(interpret))]
|
||||||
|
(vswap! ctx update-ctx {name result})
|
||||||
|
result ;; TODO: test this!
|
||||||
|
))))
|
||||||
|
|
||||||
|
(defn interpret-ast [ast ctx]
|
||||||
|
(case (::ast/type ast)
|
||||||
|
|
||||||
|
::ast/atom (:value ast)
|
||||||
|
|
||||||
|
::ast/word (resolve-word (:word ast) ctx)
|
||||||
|
|
||||||
|
::ast/let (interpret-let ast ctx)
|
||||||
|
|
||||||
|
::ast/if (interpret-if ast ctx)
|
||||||
|
|
||||||
|
::ast/match (interpret-match ast ctx)
|
||||||
|
|
||||||
|
::ast/cond (interpret-cond ast ctx)
|
||||||
|
|
||||||
|
::ast/synthetic (interpret-synthetic ast ctx)
|
||||||
|
|
||||||
|
::ast/fn (interpret-fn ast ctx)
|
||||||
|
|
||||||
|
::ast/pipeline (interpret-do ast ctx)
|
||||||
|
|
||||||
|
::ast/placeholder ::data/placeholder
|
||||||
|
|
||||||
|
::ast/ns (interpret-ns ast ctx)
|
||||||
|
|
||||||
|
::ast/import (interpret-import ast ctx)
|
||||||
|
|
||||||
|
::ast/block
|
||||||
|
(let [exprs (:exprs ast)
|
||||||
|
inner (pop exprs)
|
||||||
|
last (peek exprs)
|
||||||
|
ctx (volatile! {::parent ctx})]
|
||||||
|
(run! #(interpret-ast % ctx) inner)
|
||||||
|
(interpret-ast last ctx))
|
||||||
|
|
||||||
|
::ast/script
|
||||||
|
(let [exprs (:exprs ast)
|
||||||
|
inner (pop exprs)
|
||||||
|
last (peek exprs)
|
||||||
|
ctx (volatile! prelude/prelude)]
|
||||||
|
(run! #(interpret-ast % ctx) inner)
|
||||||
|
(interpret-ast last ctx))
|
||||||
|
|
||||||
|
;; note that, excepting tuples and structs,
|
||||||
|
;; runtime representations are bare
|
||||||
|
;; tuples are vectors with a special first member
|
||||||
|
::ast/tuple
|
||||||
|
(let [members (:members ast)]
|
||||||
|
(into
|
||||||
|
[(if (:partial ast) ::data/partial ::data/tuple)]
|
||||||
|
(map #(interpret-ast % ctx)) members))
|
||||||
|
|
||||||
|
::ast/list
|
||||||
|
(let [members (:members ast)]
|
||||||
|
(into [] (map #(interpret-ast % ctx)) members))
|
||||||
|
|
||||||
|
::ast/set
|
||||||
|
(let [members (:members ast)]
|
||||||
|
(into #{} (map #(interpret-ast % ctx)) members))
|
||||||
|
|
||||||
|
::ast/hash
|
||||||
|
(let [members (:members ast)]
|
||||||
|
(into {} (map-values #(interpret-ast % ctx)) members))
|
||||||
|
|
||||||
|
::ast/struct
|
||||||
|
(let [members (:members ast)]
|
||||||
|
(into {::data/struct true} (map-values #(interpret-ast % ctx)) members))
|
||||||
|
|
||||||
|
(throw (ex-info "Unknown AST node type" {:node ast}))))
|
||||||
|
|
||||||
|
(defn interpret [parsed]
|
||||||
|
(try
|
||||||
|
(interpret-ast (::parser/ast parsed) {})
|
||||||
|
(catch clojure.lang.ExceptionInfo e
|
||||||
|
(println "Ludus panicked!")
|
||||||
|
(println (ex-message e))
|
||||||
|
(pp/pprint (ex-data e))
|
||||||
|
(System/exit 67))))
|
||||||
|
|
||||||
|
(comment
|
||||||
|
|
||||||
|
(def source "
|
||||||
|
|
||||||
|
let foo = 2
|
||||||
|
|
||||||
|
match foo with {
|
||||||
|
1 -> :one
|
||||||
|
2 -> :two
|
||||||
|
else -> :oops
|
||||||
|
}
|
||||||
|
|
||||||
|
ns bar {
|
||||||
|
foo
|
||||||
|
}
|
||||||
|
|
||||||
|
bar :foo
|
||||||
|
|
||||||
|
")
|
||||||
|
|
||||||
|
(println "")
|
||||||
|
(println "****************************************")
|
||||||
|
(println "*** *** NEW INTERPRETATION *** ***")
|
||||||
|
(println "")
|
||||||
|
|
||||||
|
(-> source
|
||||||
|
(scanner/scan)
|
||||||
|
(parser/parse)
|
||||||
|
(interpret)
|
||||||
|
(pp/pprint)))
|
||||||
|
|
||||||
|
(comment "
|
||||||
|
|
||||||
|
Left to do:
|
||||||
|
* if-let pattern
|
||||||
|
* improve panics
|
||||||
|
* add location info for panics
|
||||||
|
* refactor calling keywords
|
||||||
|
* refactor accessing structs vs. hashes
|
||||||
|
|
||||||
|
")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
851
src/ludus/parser.cljc
Normal file
851
src/ludus/parser.cljc
Normal file
|
@ -0,0 +1,851 @@
|
||||||
|
(ns ludus.parser
|
||||||
|
(:require
|
||||||
|
[ludus.token :as token]
|
||||||
|
[ludus.scanner :as scanner]
|
||||||
|
[ludus.ast :as ast]
|
||||||
|
[clojure.pprint :as pp]
|
||||||
|
[clojure.set :as s]))
|
||||||
|
|
||||||
|
;; a parser map and some functions to work with them
|
||||||
|
(defn- parser [tokens]
|
||||||
|
{::tokens tokens ::token 0 ::ast {} ::errors []})
|
||||||
|
|
||||||
|
(defn- current [parser]
|
||||||
|
(nth (::tokens parser) (::token parser) nil))
|
||||||
|
|
||||||
|
(defn- ppeek [parser]
|
||||||
|
(nth (::tokens parser) (inc (::token parser)) nil))
|
||||||
|
|
||||||
|
(defn- at-end? [parser]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(or (nil? curr) (= ::token/eof (::token/type curr)))))
|
||||||
|
|
||||||
|
(defn- advance [parser]
|
||||||
|
(update parser ::token inc))
|
||||||
|
|
||||||
|
(defn- token-type [parser]
|
||||||
|
(::token/type (current parser)))
|
||||||
|
|
||||||
|
(defn- node-type [parser]
|
||||||
|
(get-in parser [::ast ::ast/type]))
|
||||||
|
|
||||||
|
;; some forward declarations
|
||||||
|
(declare parse-expr parse-word parse-pattern)
|
||||||
|
|
||||||
|
;; handle some errors
|
||||||
|
(def sync-on #{::token/newline
|
||||||
|
::token/semicolon
|
||||||
|
::token/comma
|
||||||
|
::token/rparen
|
||||||
|
::token/rbracket
|
||||||
|
::token/rbrace
|
||||||
|
::token/eof})
|
||||||
|
|
||||||
|
(defn- psync [parser message origin end]
|
||||||
|
(let [poison {::ast/type ::ast/poison
|
||||||
|
:message message
|
||||||
|
:origin origin
|
||||||
|
:end end}]
|
||||||
|
(-> parser
|
||||||
|
(assoc ::ast poison)
|
||||||
|
(update ::errors conj poison))))
|
||||||
|
|
||||||
|
(defn- poisoned? [parser]
|
||||||
|
(= ::ast/poison (get-in parser [::ast ::ast/type])))
|
||||||
|
|
||||||
|
(defn- panic
|
||||||
|
([parser message] (panic parser message sync-on))
|
||||||
|
([parser message sync-on]
|
||||||
|
(println (str "PANIC!!! in the parser: " message))
|
||||||
|
(let [sync-on (conj (if (set? sync-on) sync-on #{sync-on}) ::token/eof)
|
||||||
|
origin (current parser)]
|
||||||
|
(loop [parser parser]
|
||||||
|
(let [curr (current parser)
|
||||||
|
type (::token/type curr)]
|
||||||
|
(if (or (at-end? parser) (contains? sync-on type))
|
||||||
|
(psync parser message origin curr)
|
||||||
|
(recur (advance parser))))))))
|
||||||
|
|
||||||
|
;; some helper functions
|
||||||
|
(defn- expect [tokens message parser]
|
||||||
|
(let [curr (current parser)
|
||||||
|
tokens (if (set? tokens) tokens #{tokens})
|
||||||
|
type (::token/type curr)]
|
||||||
|
(if (contains? tokens type)
|
||||||
|
(advance parser)
|
||||||
|
(-> parser
|
||||||
|
(advance)
|
||||||
|
(panic message tokens)))))
|
||||||
|
|
||||||
|
(defn- expect* [tokens message parser]
|
||||||
|
(let [curr (current parser)
|
||||||
|
tokens (if (set? tokens) tokens #{tokens})
|
||||||
|
type (::token/type curr)]
|
||||||
|
(if (contains? tokens type)
|
||||||
|
{:success true :parser (advance parser)}
|
||||||
|
{:success false :parser (panic (advance parser) message)})))
|
||||||
|
|
||||||
|
(defn- accept [tokens parser]
|
||||||
|
(let [curr (current parser)
|
||||||
|
tokens (if (set? tokens) tokens #{tokens})
|
||||||
|
type (::token/type curr)]
|
||||||
|
(if (contains? tokens type)
|
||||||
|
(advance parser)
|
||||||
|
parser)))
|
||||||
|
|
||||||
|
(defn- accept-many [tokens parser]
|
||||||
|
(let [tokens (if (set? tokens) tokens #{tokens})]
|
||||||
|
(loop [parser parser]
|
||||||
|
(let [curr (current parser)
|
||||||
|
type (::token/type curr)]
|
||||||
|
(if (contains? tokens type)
|
||||||
|
(recur (advance parser))
|
||||||
|
parser)))))
|
||||||
|
|
||||||
|
;; various parsing functions
|
||||||
|
(defn- parse-atom [parser]
|
||||||
|
(let [token (current parser)]
|
||||||
|
(-> parser
|
||||||
|
(advance)
|
||||||
|
(assoc ::ast {::ast/type ::ast/atom
|
||||||
|
:token token
|
||||||
|
:value (::token/literal token)}))))
|
||||||
|
|
||||||
|
;; just a quick and dirty map to associate atomic words with values
|
||||||
|
(def atomic-words {::token/nil nil
|
||||||
|
::token/true true
|
||||||
|
::token/false false})
|
||||||
|
|
||||||
|
(defn parse-atomic-word [parser]
|
||||||
|
(let [token (current parser)]
|
||||||
|
(-> parser
|
||||||
|
(advance)
|
||||||
|
(assoc ::ast {::ast/type ::ast/atom
|
||||||
|
:token token
|
||||||
|
:value (get atomic-words (::token/type token))}))))
|
||||||
|
|
||||||
|
(defn- add-member [members member]
|
||||||
|
(if (nil? member)
|
||||||
|
members
|
||||||
|
(conj members member)))
|
||||||
|
|
||||||
|
(defn- contains-placeholder? [members]
|
||||||
|
(< 0 (count (filter #(= ::ast/placeholder (::ast/type %1)) members))))
|
||||||
|
|
||||||
|
(defn- parse-fn-tuple [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||||
|
members []
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rparen (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/tuple
|
||||||
|
:length (count ms)
|
||||||
|
:members ms
|
||||||
|
:partial (contains-placeholder? ms)}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbrace ::token/rbracket)
|
||||||
|
(panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/placeholder
|
||||||
|
(if (contains-placeholder? members)
|
||||||
|
(recur
|
||||||
|
(advance parser)
|
||||||
|
members
|
||||||
|
(panic parser "Partially applied functions must be unary. (Only one placeholder allowed in partial application.)" curr))
|
||||||
|
(recur
|
||||||
|
(advance parser) members {::ast/type ::ast/placeholder}))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof)
|
||||||
|
|
||||||
|
(let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rparen})]
|
||||||
|
(recur parsed members (::ast parsed)))))))
|
||||||
|
|
||||||
|
(defn- parse-tuple [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||||
|
members []
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rparen (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/tuple
|
||||||
|
:length (count ms)
|
||||||
|
:members ms}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbrace ::token/rbracket)
|
||||||
|
(panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/placeholder
|
||||||
|
(recur
|
||||||
|
(advance parser)
|
||||||
|
members
|
||||||
|
(panic parser "Placeholders in tuples may only be in function calls." curr))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof)
|
||||||
|
|
||||||
|
(let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rparen})]
|
||||||
|
(recur parsed members (::ast parsed)))))))
|
||||||
|
|
||||||
|
(defn- parse-list [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||||
|
members []
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rbracket (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/list
|
||||||
|
:members ms}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbrace ::token/rparen)
|
||||||
|
(panic parser (str "Mismatched enclosure in list: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated list" ::token/eof)
|
||||||
|
|
||||||
|
(let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rbracket})]
|
||||||
|
(recur parsed members (::ast parsed)))))))
|
||||||
|
|
||||||
|
(defn- parse-set [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||||
|
members []
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rbrace (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/set
|
||||||
|
:members ms}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbracket ::token/rparen)
|
||||||
|
(panic parser (str "Mismatched enclosure in set: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated set" ::token/eof)
|
||||||
|
|
||||||
|
(let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rbrace})]
|
||||||
|
(recur parsed members (::ast parsed)))))))
|
||||||
|
|
||||||
|
(defn- parse-hash [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||||
|
members {}
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rbrace (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/hash
|
||||||
|
:members ms}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbracket ::token/rparen)
|
||||||
|
(panic parser (str "Mismatched enclosure in hashmap: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated hashmap" ::token/eof)
|
||||||
|
|
||||||
|
::token/word
|
||||||
|
(if (not current_member) (let [parsed (parse-word parser) word (get-in parsed [::ast :word])]
|
||||||
|
(recur parsed members {(keyword word) (::ast parsed)}))
|
||||||
|
(panic parser "Hashmap entries must be single words or keyword+expression pairs." #{::token/rbrace}))
|
||||||
|
|
||||||
|
::token/keyword
|
||||||
|
(if (not current_member) (let [kw (parse-atom parser) expr (parse-expr kw #{::token/comma ::token/newline ::token/rbrace})]
|
||||||
|
(recur expr members {(:value (::ast kw)) (::ast expr)}))
|
||||||
|
(panic parser "Hashmap entries must be single words or keyword+expression pairs." #{::token/rbrace}))
|
||||||
|
|
||||||
|
(panic parser "Hashmap entries must be single words or keyword+expression pairs" #{::token/rbrace})))))
|
||||||
|
|
||||||
|
(defn- parse-struct [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||||
|
members {}
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rbrace (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/struct
|
||||||
|
:members ms}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbracket ::token/rparen)
|
||||||
|
(panic parser (str "Mismatched enclosure in struct: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated struct" ::token/eof)
|
||||||
|
|
||||||
|
::token/word
|
||||||
|
(if (not current_member) (let [parsed (parse-word parser) word (get-in parsed [::ast :word])]
|
||||||
|
(recur parsed members {(keyword word) (::ast parsed)}))
|
||||||
|
(panic parser "Struct entries must be single words or keyword+expression pairs." #{::token/rbrace}))
|
||||||
|
|
||||||
|
::token/keyword
|
||||||
|
(if (not current_member) (let [kw (parse-atom parser) expr (parse-expr kw #{::token/comma ::token/newline ::token/rbrace})]
|
||||||
|
(recur expr members {(:value (::ast kw)) (::ast expr)}))
|
||||||
|
(panic parser "Struct entries must be single words or keyword+expression pairs." #{::token/rbrace}))
|
||||||
|
|
||||||
|
(panic parser "Struct entries must be single words or keyword+expression pairs" #{::token/rbrace})))))
|
||||||
|
|
||||||
|
(defn- parse-ns [ns-root]
|
||||||
|
(let [name (expect* #{::token/word} "Expected ns name" (advance ns-root))
|
||||||
|
origin (expect* #{::token/lbrace} "Expected { after ns name" (:parser name))]
|
||||||
|
(cond
|
||||||
|
(not (:success name)) (panic parser "Expected ns name" #{::token/newline})
|
||||||
|
|
||||||
|
(not (:success origin)) (panic (:parser name) "Expected { after ns name")
|
||||||
|
|
||||||
|
:else
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (:parser origin))
|
||||||
|
members {}
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rbrace (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/ns
|
||||||
|
:name (get-in (parse-word (advance ns-root)) [::ast :word])
|
||||||
|
:members ms}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbracket ::token/rparen)
|
||||||
|
(panic parser (str "Mismatched enclosure in ns: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated ns" ::token/eof)
|
||||||
|
|
||||||
|
::token/word
|
||||||
|
(if (not current_member) (let [parsed (parse-word parser) word (get-in parsed [::ast :word])]
|
||||||
|
(recur parsed members {(keyword word) (::ast parsed)}))
|
||||||
|
(panic parser "ns entries must be single words or keyword+expression pairs." #{::token/rbrace}))
|
||||||
|
|
||||||
|
::token/keyword
|
||||||
|
(if (not current_member) (let [kw (parse-atom parser) expr (parse-expr kw #{::token/comma ::token/newline ::token/rbrace})]
|
||||||
|
(recur expr members {(:value (::ast kw)) (::ast expr)}))
|
||||||
|
(panic parser "ns entries must be single words or keyword+expression pairs." #{::token/rbrace}))
|
||||||
|
|
||||||
|
(panic parser "ns entries must be single words or keyword+expression pairs" #{::token/rbrace})))))))
|
||||||
|
|
||||||
|
(defn- parse-block [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/semicolon} (advance origin))
|
||||||
|
exprs []
|
||||||
|
current_expr nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rbrace
|
||||||
|
(let [es (add-member exprs current_expr)]
|
||||||
|
(if (empty? es)
|
||||||
|
(advance (panic parser "Blocks must have at least one expression"))
|
||||||
|
(assoc (advance parser) ::ast {::ast/type ::ast/block
|
||||||
|
:exprs es})))
|
||||||
|
|
||||||
|
(::token/semicolon ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/newline ::token/semicolon} parser)
|
||||||
|
(add-member exprs current_expr) nil)
|
||||||
|
|
||||||
|
(::token/rbracket ::token/rparen)
|
||||||
|
(panic parser (str "Mismatched enclosure in block: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated block" ::token/eof)
|
||||||
|
|
||||||
|
(let [parsed
|
||||||
|
(if current_expr
|
||||||
|
(panic parser "Expected end of expression" #{::token/semicolon ::token/newline})
|
||||||
|
(parse-expr parser))]
|
||||||
|
(recur parsed exprs (::ast parsed)))))))
|
||||||
|
|
||||||
|
(defn parse-script [parser]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/semicolon} parser)
|
||||||
|
exprs []
|
||||||
|
current_expr nil]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/eof
|
||||||
|
(let [es (add-member exprs current_expr)]
|
||||||
|
(if (empty? es)
|
||||||
|
(panic parser "Scripts must have at least one expression")
|
||||||
|
(assoc parser ::ast {::ast/type ::ast/script :exprs es})))
|
||||||
|
|
||||||
|
(::token/semicolon ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/semicolon ::token/newline} parser)
|
||||||
|
(add-member exprs current_expr)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(let [parsed
|
||||||
|
(if current_expr
|
||||||
|
(panic parser "Expected end of expression" #{::token/semicolon ::token/newline})
|
||||||
|
(parse-expr parser))]
|
||||||
|
|
||||||
|
(recur parsed exprs (::ast parsed))))))
|
||||||
|
|
||||||
|
(defn- parse-synthetic [parser]
|
||||||
|
(loop [parser parser
|
||||||
|
terms []]
|
||||||
|
(let [curr (current parser)
|
||||||
|
type (::token/type curr)]
|
||||||
|
(case type
|
||||||
|
::token/keyword
|
||||||
|
(recur (advance parser) (conj terms (::ast (parse-atom parser))))
|
||||||
|
|
||||||
|
::token/word
|
||||||
|
(recur (advance parser) (conj terms (::ast (parse-word parser))))
|
||||||
|
|
||||||
|
::token/lparen
|
||||||
|
(let [parsed (parse-fn-tuple parser)]
|
||||||
|
(recur parsed (conj terms (::ast parsed))))
|
||||||
|
|
||||||
|
(assoc parser ::ast {::ast/type ::ast/synthetic :terms terms})))))
|
||||||
|
|
||||||
|
(defn- parse-word [parser]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(-> parser
|
||||||
|
(advance)
|
||||||
|
(assoc ::ast {::ast/type ::ast/word :word (::token/lexeme curr)}))))
|
||||||
|
|
||||||
|
(def sync-pattern (s/union sync-on #{::token/equals ::token/rarrow}))
|
||||||
|
|
||||||
|
(defn- parse-tuple-pattern [origin]
|
||||||
|
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||||
|
members []
|
||||||
|
current_member nil]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (token-type parser)
|
||||||
|
::token/rparen (let [ms (add-member members current_member)]
|
||||||
|
(assoc (advance parser) ::ast
|
||||||
|
{::ast/type ::ast/tuple
|
||||||
|
:length (count ms)
|
||||||
|
:members ms}))
|
||||||
|
|
||||||
|
(::token/comma ::token/newline)
|
||||||
|
(recur
|
||||||
|
(accept-many #{::token/comma ::token/newline} parser)
|
||||||
|
(add-member members current_member) nil)
|
||||||
|
|
||||||
|
(::token/rbrace ::token/rbracket)
|
||||||
|
(panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr)))
|
||||||
|
|
||||||
|
::token/eof
|
||||||
|
(panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof)
|
||||||
|
|
||||||
|
(let [parsed (parse-pattern parser)]
|
||||||
|
(recur parsed members (::ast parsed)))))))
|
||||||
|
|
||||||
|
(defn- parse-pattern [parser]
|
||||||
|
(let [curr (current parser)
|
||||||
|
type (::token/type curr)]
|
||||||
|
(case type
|
||||||
|
(::token/placeholder ::token/ignored) (-> parser
|
||||||
|
(advance)
|
||||||
|
(assoc ::ast {::ast/type ::ast/placeholder}))
|
||||||
|
|
||||||
|
::token/word (parse-word parser)
|
||||||
|
|
||||||
|
(::token/number ::token/string ::token/keyword) (parse-atom parser)
|
||||||
|
|
||||||
|
::token/lparen (parse-tuple-pattern parser)
|
||||||
|
|
||||||
|
::token/error
|
||||||
|
(panic parser (:message (current parser)) sync-pattern)
|
||||||
|
|
||||||
|
(panic parser "Expected pattern" sync-pattern))))
|
||||||
|
|
||||||
|
(defn- parse-let-expr [parser pattern]
|
||||||
|
(let [expr (parse-expr parser)]
|
||||||
|
(assoc expr ::ast {::ast/type ::ast/let
|
||||||
|
:pattern (::ast pattern) :expr (::ast expr)})))
|
||||||
|
|
||||||
|
(defn- parse-assignment [parser]
|
||||||
|
(let [assignment (expect* ::token/equals "Expected assignment" parser)
|
||||||
|
success (:success assignment)]
|
||||||
|
(if success
|
||||||
|
(parse-let-expr (:parser assignment) parser)
|
||||||
|
(panic parser "Expected assignment"))))
|
||||||
|
|
||||||
|
(defn- parse-let [parser]
|
||||||
|
(let [pattern (parse-pattern (advance parser))]
|
||||||
|
(parse-assignment pattern)))
|
||||||
|
|
||||||
|
(defn- parse-else [parser]
|
||||||
|
(let [ast (::ast parser)
|
||||||
|
else-kw (expect* ::token/else "Expected else clause after then" parser)
|
||||||
|
success (:success else-kw)
|
||||||
|
else-kw-parser (:parser else-kw)]
|
||||||
|
(if success
|
||||||
|
(let [expr (parse-expr else-kw-parser)
|
||||||
|
else-expr (::ast expr)]
|
||||||
|
(assoc expr ::ast (assoc ast :else else-expr)))
|
||||||
|
else-kw-parser)))
|
||||||
|
|
||||||
|
(defn- parse-then [parser]
|
||||||
|
(let [ast (::ast parser)
|
||||||
|
then-kw (expect* ::token/then "Expected then clause after if" parser)
|
||||||
|
success (:success then-kw)
|
||||||
|
then-kw-parser (:parser then-kw)]
|
||||||
|
(if success
|
||||||
|
(let [expr (parse-expr then-kw-parser (conj sync-on ::token/else))
|
||||||
|
then-expr (::ast expr)]
|
||||||
|
(parse-else (accept ::token/newline (assoc expr ::ast (assoc ast :then then-expr)))))
|
||||||
|
then-kw-parser)))
|
||||||
|
|
||||||
|
(defn- parse-if [parser]
|
||||||
|
(let [if-expr (parse-expr (advance parser) #{::token/newline ::token/then})
|
||||||
|
ast (assoc if-expr ::ast {::ast/type ::ast/if :if (::ast if-expr)})]
|
||||||
|
(parse-then (accept ::token/newline ast))))
|
||||||
|
|
||||||
|
(defn- parse-match-clause [parser]
|
||||||
|
(let [pattern (if (= ::token/else (token-type parser))
|
||||||
|
(-> parser (advance) (assoc ::ast {::ast/type ::ast/placeholder}))
|
||||||
|
(parse-pattern parser))
|
||||||
|
rarrow (expect* #{::token/rarrow} "Expected arrow after pattern" pattern)]
|
||||||
|
(if (:success rarrow)
|
||||||
|
(let [body (parse-expr (:parser rarrow))]
|
||||||
|
(assoc body ::ast {::ast/type ::ast/clause
|
||||||
|
:pattern (::ast pattern) :body (::ast body)}))
|
||||||
|
(panic pattern "Expected -> in match clause. Clauses must be in the form pattern -> expression" #{::token/newline ::token/rbrace}))))
|
||||||
|
|
||||||
|
(defn- parse-match-clauses [parser]
|
||||||
|
(loop [parser (accept-many #{::token/newline} (advance parser))
|
||||||
|
clauses []]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (::token/type curr)
|
||||||
|
::token/rbrace
|
||||||
|
(if (< 0 (count clauses))
|
||||||
|
(assoc (advance parser) ::ast {::ast/type ::ast/clauses :clauses clauses})
|
||||||
|
(panic parser "Expected one or more clauses" #{::rbrace}))
|
||||||
|
|
||||||
|
::token/newline
|
||||||
|
(recur (accept-many #{::token/newline} parser) clauses)
|
||||||
|
|
||||||
|
(let [clause (parse-match-clause parser)]
|
||||||
|
(recur (accept-many #{::token/newline} clause) (conj clauses (::ast clause))))))))
|
||||||
|
|
||||||
|
(defn- parse-match [parser]
|
||||||
|
(let [match-expr (parse-expr (advance parser) #{::token/with})
|
||||||
|
match-header (expect* #{::token/with} "Expected with" match-expr)]
|
||||||
|
(if (:success match-header)
|
||||||
|
(let [clauses (:parser match-header)]
|
||||||
|
(if (= (token-type clauses) ::token/lbrace)
|
||||||
|
;; match expression with one or many clauses in braces
|
||||||
|
(let [clauses (parse-match-clauses clauses)]
|
||||||
|
(assoc clauses ::ast {::ast/type ::ast/match
|
||||||
|
:expr (::ast match-expr)
|
||||||
|
:clauses (get-in clauses [::ast :clauses])}))
|
||||||
|
;; match expression with single match clause
|
||||||
|
(let [clause (parse-match-clause clauses)]
|
||||||
|
(assoc clause ::ast {::ast/type ::ast/match
|
||||||
|
:expr (::ast match-expr)
|
||||||
|
:clauses [(::ast clause)]}))))
|
||||||
|
|
||||||
|
(panic parser "Expected with after match expression"))))
|
||||||
|
|
||||||
|
(defn- parse-cond-clause [parser]
|
||||||
|
(let [expr (if
|
||||||
|
(contains? #{::token/else ::token/placeholder} (token-type parser))
|
||||||
|
(-> parser
|
||||||
|
(advance)
|
||||||
|
(assoc ::ast {::ast/type ::ast/atom
|
||||||
|
:token (current parser)
|
||||||
|
:value true}))
|
||||||
|
(parse-expr parser))
|
||||||
|
rarrow (expect* #{::token/rarrow} "Expected arrow after expression in cond clause" expr)]
|
||||||
|
(if (:success rarrow)
|
||||||
|
(let [body (parse-expr (:parser rarrow))]
|
||||||
|
(assoc body ::ast {::ast/type ::ast/clause
|
||||||
|
:test (::ast expr) :body (::ast body)}))
|
||||||
|
(panic expr "Expected -> in cond clause. Clauses must be in the form test_expression -> result_expression" #{::token/newline ::token/rbrace}))))
|
||||||
|
|
||||||
|
(defn- parse-cond-clauses [parser]
|
||||||
|
(loop [parser (accept-many #{::token/newline} parser)
|
||||||
|
clauses []]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (::token/type curr)
|
||||||
|
::token/rbrace
|
||||||
|
(if (< 0 (count clauses))
|
||||||
|
(assoc (advance parser) ::ast {::ast/type ::ast/clauses :clauses clauses})
|
||||||
|
(panic parser "Expected one or more clauses" #{::rbrace}))
|
||||||
|
|
||||||
|
|
||||||
|
::token/newline
|
||||||
|
(recur (accept-many #{::token/newline} parser) clauses)
|
||||||
|
|
||||||
|
(let [clause (parse-cond-clause parser)]
|
||||||
|
(recur (accept-many #{::token/newline} clause) (conj clauses (::ast clause))))))))
|
||||||
|
|
||||||
|
(defn- parse-cond [parser]
|
||||||
|
(let [header
|
||||||
|
(expect* #{::token/lbrace} "Expected { after cond" (advance parser))]
|
||||||
|
(if (:success header)
|
||||||
|
(let [clauses (parse-cond-clauses (:parser header))]
|
||||||
|
(assoc clauses ::ast {::ast/type ::ast/cond
|
||||||
|
:clauses (get-in clauses [::ast :clauses])})
|
||||||
|
)
|
||||||
|
(panic parser "Expected { after cond")
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defn- parse-fn-clause [parser]
|
||||||
|
(if (not (= ::token/lparen (token-type parser)))
|
||||||
|
(panic parser "Function clauses must begin with tuple patterns")
|
||||||
|
(let [pattern (parse-tuple-pattern parser)
|
||||||
|
arrow (expect* #{::token/rarrow} "Expected arrow" pattern)
|
||||||
|
body (parse-expr (:parser arrow))]
|
||||||
|
(if (:success arrow)
|
||||||
|
(assoc body ::ast {::ast/type ::ast/clause
|
||||||
|
:pattern (::ast pattern) :body (::ast body)})
|
||||||
|
(panic pattern "Expected -> in function clause. Clauses must be in the form of (pattern) -> expression")))))
|
||||||
|
|
||||||
|
(defn- parse-fn-clauses [parser]
|
||||||
|
(loop [parser (accept-many #{::token/newline} (advance parser))
|
||||||
|
clauses []]
|
||||||
|
(let [curr (current parser)]
|
||||||
|
(case (::token/type curr)
|
||||||
|
::token/rbrace
|
||||||
|
(if (< 0 (count clauses))
|
||||||
|
(assoc (advance parser) ::ast {::ast/type ::ast/clauses :clauses clauses})
|
||||||
|
(panic parser "Expected one or more function clauses" #{::token/rbrace}))
|
||||||
|
|
||||||
|
::token/newline
|
||||||
|
(recur (accept-many #{::token/newline} parser) clauses)
|
||||||
|
|
||||||
|
(let [clause (parse-fn-clause parser)]
|
||||||
|
(recur (accept-many #{::token/newline} clause) (conj clauses (::ast clause))))))))
|
||||||
|
|
||||||
|
(defn- parse-named-fn [parser]
|
||||||
|
(let [name (parse-word parser)]
|
||||||
|
(case (token-type name)
|
||||||
|
::token/lparen
|
||||||
|
(let [clause (parse-fn-clause name)]
|
||||||
|
(assoc clause ::ast {::ast/type ::ast/fn
|
||||||
|
:name (get-in name [::ast :word])
|
||||||
|
:clauses [(::ast clause)]}))
|
||||||
|
|
||||||
|
::token/lbrace
|
||||||
|
(let [clauses (parse-fn-clauses name)]
|
||||||
|
(assoc clauses ::ast {::ast/type ::ast/fn
|
||||||
|
:name (get-in name [::ast :word])
|
||||||
|
:clauses (get-in clauses [::ast :clauses])}))
|
||||||
|
|
||||||
|
(panic name "Expected one or more function clauses"))))
|
||||||
|
|
||||||
|
(defn- parse-fn [parser]
|
||||||
|
(let [first (advance parser)]
|
||||||
|
(case (::token/type (current first))
|
||||||
|
::token/lparen
|
||||||
|
(let [clause (parse-fn-clause first)]
|
||||||
|
(assoc clause ::ast {::ast/type ::ast/fn
|
||||||
|
:name ::ast/anon
|
||||||
|
:clauses [(::ast clause)]}))
|
||||||
|
|
||||||
|
::token/word (parse-named-fn first)
|
||||||
|
|
||||||
|
(panic parser "Expected name or clause after fn"))))
|
||||||
|
|
||||||
|
(defn- parse-do [parser]
|
||||||
|
(let [first (advance parser)]
|
||||||
|
(loop [parser first
|
||||||
|
exprs []]
|
||||||
|
(let [expr (parse-expr parser)
|
||||||
|
expr+newline (accept ::token/newline expr)
|
||||||
|
next (token-type expr+newline)]
|
||||||
|
(if (= ::token/pipeline next)
|
||||||
|
(recur (advance expr+newline) (conj exprs (::ast expr)))
|
||||||
|
(assoc expr ::ast {::ast/type ::ast/pipeline
|
||||||
|
:exprs (conj exprs (::ast expr))})
|
||||||
|
)))))
|
||||||
|
|
||||||
|
(defn- parse-import [parser]
|
||||||
|
(let [path (parse-atom (advance parser))
|
||||||
|
as (expect* #{::token/as} "Expected as after path" path)
|
||||||
|
named? (if (:success as)
|
||||||
|
(expect* #{::token/word} "Expected name binding after as" (:parser as))
|
||||||
|
nil)
|
||||||
|
name (if (:success named?)
|
||||||
|
(parse-word (:parser as))
|
||||||
|
nil
|
||||||
|
)]
|
||||||
|
(cond
|
||||||
|
(not= ::token/string (token-type (advance parser)))
|
||||||
|
(panic parser "Expected path after import" #{::token/newline})
|
||||||
|
|
||||||
|
(not (:success as))
|
||||||
|
(panic parser "Expected as after path" #{::token/newline})
|
||||||
|
|
||||||
|
(not (:success named?))
|
||||||
|
(panic parser "Expected name binding after as")
|
||||||
|
|
||||||
|
:else
|
||||||
|
(assoc name ::ast {::ast/type ::ast/import
|
||||||
|
:path (get-in path [::ast :value])
|
||||||
|
:name (get-in name [::ast :word])}))))
|
||||||
|
|
||||||
|
(defn- parse-expr
|
||||||
|
([parser] (parse-expr parser sync-on))
|
||||||
|
([parser sync-on]
|
||||||
|
(let [token (current parser)]
|
||||||
|
(case (::token/type token)
|
||||||
|
|
||||||
|
(::token/number ::token/string)
|
||||||
|
(parse-atom parser)
|
||||||
|
|
||||||
|
::token/keyword
|
||||||
|
(let [next (ppeek parser)
|
||||||
|
type (::token/type next)]
|
||||||
|
(if (= type ::token/lparen)
|
||||||
|
(parse-synthetic parser)
|
||||||
|
(parse-atom parser)))
|
||||||
|
|
||||||
|
::token/word
|
||||||
|
(let [next (ppeek parser)
|
||||||
|
type (::token/type next)]
|
||||||
|
(case type
|
||||||
|
(::token/lparen ::token/keyword) (parse-synthetic parser)
|
||||||
|
(parse-word parser)))
|
||||||
|
|
||||||
|
(::token/nil ::token/true ::token/false)
|
||||||
|
(parse-atomic-word parser)
|
||||||
|
|
||||||
|
::token/lparen (parse-tuple parser)
|
||||||
|
|
||||||
|
::token/lbracket (parse-list parser)
|
||||||
|
|
||||||
|
::token/startset (parse-set parser)
|
||||||
|
|
||||||
|
::token/starthash (parse-hash parser)
|
||||||
|
|
||||||
|
::token/startstruct (parse-struct parser)
|
||||||
|
|
||||||
|
::token/lbrace (parse-block parser)
|
||||||
|
|
||||||
|
::token/let (parse-let parser)
|
||||||
|
|
||||||
|
::token/if (parse-if parser)
|
||||||
|
|
||||||
|
::token/match (parse-match parser)
|
||||||
|
|
||||||
|
::token/fn (parse-fn parser)
|
||||||
|
|
||||||
|
::token/do (parse-do parser)
|
||||||
|
|
||||||
|
::token/cond (parse-cond parser)
|
||||||
|
|
||||||
|
::token/ns (parse-ns parser)
|
||||||
|
|
||||||
|
::token/import (parse-import parser)
|
||||||
|
|
||||||
|
;; TODO: improve handling of comments?
|
||||||
|
;; Scanner now just skips comments
|
||||||
|
;; ::token/comment (advance parser)
|
||||||
|
|
||||||
|
::token/error (panic parser (:message token) sync-on)
|
||||||
|
|
||||||
|
(::token/rparen ::token/rbrace ::token/rbracket)
|
||||||
|
(panic parser (str "Unbalanced enclosure: " (::token/lexeme token)))
|
||||||
|
|
||||||
|
(::token/semicolon ::token/comma)
|
||||||
|
(panic parser (str "Unexpected delimiter: " (::token/lexeme token)))
|
||||||
|
|
||||||
|
(panic parser "Expected expression" sync-on)))))
|
||||||
|
|
||||||
|
(defn parse [lexed]
|
||||||
|
(-> lexed
|
||||||
|
(:tokens)
|
||||||
|
(parser)
|
||||||
|
(parse-script)))
|
||||||
|
|
||||||
|
(comment
|
||||||
|
(def pp pp/pprint)
|
||||||
|
(def source "cond { _ -> :foo }
|
||||||
|
|
||||||
|
")
|
||||||
|
(def lexed (scanner/scan source))
|
||||||
|
(def tokens (:tokens lexed))
|
||||||
|
(def p (parser tokens))
|
||||||
|
|
||||||
|
(println "")
|
||||||
|
(println "")
|
||||||
|
(println "******************************************************")
|
||||||
|
(println "")
|
||||||
|
(println "*** *** NEW PARSE *** ***")
|
||||||
|
|
||||||
|
(-> p
|
||||||
|
(parse-script)
|
||||||
|
(::ast)
|
||||||
|
(pp)))
|
||||||
|
|
||||||
|
(comment "
|
||||||
|
Further thoughts/still to do:
|
||||||
|
* Functions docstrings
|
||||||
|
* Cond expressions
|
||||||
|
* Loops
|
||||||
|
* Structs
|
||||||
|
* Namespaces
|
||||||
|
* Types (:|)
|
||||||
|
* Modules
|
||||||
|
* Add `as` clauses to patterns
|
||||||
|
* Add `when` clauses to patterns
|
||||||
|
* var/mut
|
||||||
|
* ref/swap
|
||||||
|
* Splats in lists, hashmaps, sets
|
||||||
|
* AST nodes should include tokens/locations
|
||||||
|
- at current, only atoms do this
|
||||||
|
* Improve error handling in hashmap parsing
|
||||||
|
* Consider error handling in match expressions
|
||||||
|
* Add treatment of ignored variables
|
||||||
|
* Placeholders
|
||||||
|
* How much in parser, how much in analysis?
|
||||||
|
|
||||||
|
Some architectural changes:
|
||||||
|
* UGH, this code is just kind of a mess and hard to reason about
|
||||||
|
* Especially sequential forms
|
||||||
|
* Parsers are hard
|
||||||
|
* One idea:
|
||||||
|
* Refactor everything so that it returns a success or failure
|
||||||
|
* Because this is all stateless, in sequential forms, you can just do all the things
|
||||||
|
* This lets you do one let (with everything building up) and then a cond with bespoke errors/panics
|
||||||
|
* This also still lets you encapsulate parsererrors with poisoned nodes
|
||||||
|
|
||||||
|
")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
69
src/ludus/prelude.cljc
Normal file
69
src/ludus/prelude.cljc
Normal file
|
@ -0,0 +1,69 @@
|
||||||
|
(ns ludus.prelude
|
||||||
|
(:require
|
||||||
|
[ludus.data :as data]
|
||||||
|
[ludus.show]))
|
||||||
|
|
||||||
|
(def eq {:name "eq"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body =})
|
||||||
|
|
||||||
|
(def add {:name "add"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body +})
|
||||||
|
|
||||||
|
(def sub {:name "sub"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body -})
|
||||||
|
|
||||||
|
(def mult {:name "mult"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body *})
|
||||||
|
|
||||||
|
(def div {:name "div"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body /})
|
||||||
|
|
||||||
|
(def inc- {:name "inc"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body inc})
|
||||||
|
|
||||||
|
(def dec- {:name "dec"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body dec})
|
||||||
|
|
||||||
|
(def ld-not {:name "not"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body not})
|
||||||
|
|
||||||
|
(def panic! {:name "panic!"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body (fn [& args] (throw (ex-info (apply str (interpose " " args)) {})))})
|
||||||
|
|
||||||
|
(def print- {:name "print"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body (fn [& args]
|
||||||
|
(println (apply str args))
|
||||||
|
:ok)})
|
||||||
|
|
||||||
|
(declare show)
|
||||||
|
|
||||||
|
(defn- show-vector [v]
|
||||||
|
(if (= (first v) ::data/tuple)
|
||||||
|
(str "(" (apply str (into [] (comp (map (:body show)) (interpose ", ")) (next v))) ")")
|
||||||
|
(str "[" (apply str (into [] (comp (map (:body show)) (interpose ", ")) v)) "]")))
|
||||||
|
|
||||||
|
(def show {:name "show"
|
||||||
|
::data/type ::data/clj
|
||||||
|
:body ludus.show/show})
|
||||||
|
|
||||||
|
(def prelude {"eq" eq
|
||||||
|
"add" add
|
||||||
|
"panic!" panic!
|
||||||
|
"print" print-
|
||||||
|
"sub" sub
|
||||||
|
"mult" mult
|
||||||
|
"div" div
|
||||||
|
"inc" inc-
|
||||||
|
"dec" dec-
|
||||||
|
"not" not
|
||||||
|
"show" show})
|
318
src/ludus/scanner.cljc
Normal file
318
src/ludus/scanner.cljc
Normal file
|
@ -0,0 +1,318 @@
|
||||||
|
(ns ludus.scanner
|
||||||
|
(:require
|
||||||
|
[ludus.token :as token]
|
||||||
|
[clojure.pprint :as pp]
|
||||||
|
[clojure.edn :as edn]
|
||||||
|
[clojure.string :as s]))
|
||||||
|
|
||||||
|
(def reserved-words
|
||||||
|
"List of Ludus reserved words."
|
||||||
|
;; see ludus-spec repo for more info
|
||||||
|
{"as" ::token/as
|
||||||
|
"cond" ::token/cond ;; impl
|
||||||
|
"data" ::token/data
|
||||||
|
"do" ::token/do ;; impl
|
||||||
|
"else" ::token/else ;; impl
|
||||||
|
"false" ::token/false ;; impl
|
||||||
|
"fn" ::token/fn ;; impl
|
||||||
|
"if" ::token/if ;; impl
|
||||||
|
"import" ::token/import
|
||||||
|
"let" ::token/let ;; impl
|
||||||
|
"match" ::token/match ;; impl
|
||||||
|
"mut" ::token/mut
|
||||||
|
"nil" ::token/nil ;; impl
|
||||||
|
"ref" ::token/ref
|
||||||
|
"then" ::token/then ;; impl
|
||||||
|
"true" ::token/true ;; impl
|
||||||
|
"var" ::token/var
|
||||||
|
"with" ::token/with ;; impl
|
||||||
|
;; below here, probable
|
||||||
|
"defer" ::token/defer
|
||||||
|
"gen" ::token/gen
|
||||||
|
"loop" ::token/loop
|
||||||
|
"ns" ::token/ns
|
||||||
|
"recur" ::token/recur
|
||||||
|
"repeat" ::token/repeat
|
||||||
|
"test" ::token/test
|
||||||
|
"wait" ::token/wait
|
||||||
|
"yield" ::token/yield
|
||||||
|
;; below here, possible
|
||||||
|
"when" ::token/when})
|
||||||
|
|
||||||
|
(defn- new-scanner
|
||||||
|
"Creates a new scanner."
|
||||||
|
[source]
|
||||||
|
{::source source
|
||||||
|
::length (count source)
|
||||||
|
::errors []
|
||||||
|
::start 0
|
||||||
|
::current 0
|
||||||
|
::line 1
|
||||||
|
::tokens []})
|
||||||
|
|
||||||
|
(defn- at-end?
|
||||||
|
"Tests if a scanner is at end of input."
|
||||||
|
[scanner]
|
||||||
|
(>= (::current scanner) (::length scanner)))
|
||||||
|
|
||||||
|
(defn- current-char
|
||||||
|
"Gets the current character of the scanner."
|
||||||
|
[scanner]
|
||||||
|
(nth (::source scanner) (::current scanner) nil))
|
||||||
|
|
||||||
|
(defn- advance
|
||||||
|
"Advances the scanner by a single character."
|
||||||
|
[scanner]
|
||||||
|
(update scanner ::current inc))
|
||||||
|
|
||||||
|
(defn- next-char
|
||||||
|
"Gets the next character from the scanner."
|
||||||
|
[scanner]
|
||||||
|
(current-char (advance scanner)))
|
||||||
|
|
||||||
|
(defn- current-lexeme
|
||||||
|
[scanner]
|
||||||
|
(subs (::source scanner) (::start scanner) (::current scanner)))
|
||||||
|
|
||||||
|
(defn- char-in-range? [start end char]
|
||||||
|
(and char
|
||||||
|
(>= (int char) (int start))
|
||||||
|
(<= (int char) (int end))))
|
||||||
|
|
||||||
|
(defn- digit? [c]
|
||||||
|
(char-in-range? \0 \9 c))
|
||||||
|
|
||||||
|
(defn- nonzero-digit? [c]
|
||||||
|
(char-in-range? \1 \9 c))
|
||||||
|
|
||||||
|
;; for now, use very basic ASCII charset in words
|
||||||
|
;; TODO: research the implications of using the whole
|
||||||
|
;; (defn- alpha? [c] (boolean (re-find #"\p{L}" (str c))))
|
||||||
|
(defn- alpha? [c]
|
||||||
|
(or (char-in-range? \a \z c) (char-in-range? \A \Z c)))
|
||||||
|
|
||||||
|
;; legal characters in words
|
||||||
|
(def word-chars #{\_ \? \! \* \/})
|
||||||
|
|
||||||
|
(defn- word-char? [c]
|
||||||
|
(or (alpha? c) (digit? c) (contains? word-chars c)))
|
||||||
|
|
||||||
|
(defn- whitespace? [c]
|
||||||
|
(or (= c \space) (= c \tab)))
|
||||||
|
|
||||||
|
(def terminators #{\: \; \newline \{ \} \( \) \[ \] \$ \# \- \< \& \, \| nil \\})
|
||||||
|
|
||||||
|
(defn- terminates? [c]
|
||||||
|
(or (whitespace? c) (contains? terminators c)))
|
||||||
|
|
||||||
|
(defn- add-token
|
||||||
|
([scanner token-type]
|
||||||
|
(add-token scanner token-type nil))
|
||||||
|
([scanner token-type literal]
|
||||||
|
(update scanner ::tokens conj
|
||||||
|
(token/token
|
||||||
|
token-type
|
||||||
|
(current-lexeme scanner)
|
||||||
|
literal
|
||||||
|
(::line scanner)
|
||||||
|
(::start scanner)))))
|
||||||
|
|
||||||
|
;; TODO: errors should also be in the vector of tokens
|
||||||
|
;; The goal is to be able to be able to hand this to an LSP?
|
||||||
|
;; Do we need a different structure
|
||||||
|
(defn- add-error [scanner msg]
|
||||||
|
(let [token (token/token
|
||||||
|
::token/error
|
||||||
|
(current-lexeme scanner)
|
||||||
|
nil
|
||||||
|
(::line scanner)
|
||||||
|
(::start scanner))
|
||||||
|
err-token (assoc token :message msg)]
|
||||||
|
(-> scanner
|
||||||
|
(update ::errors conj err-token)
|
||||||
|
(update ::tokens conj err-token))))
|
||||||
|
|
||||||
|
(defn- add-keyword
|
||||||
|
[scanner]
|
||||||
|
(loop [scanner scanner
|
||||||
|
key ""]
|
||||||
|
(let [char (current-char scanner)]
|
||||||
|
(cond
|
||||||
|
(terminates? char) (add-token scanner ::token/keyword (keyword key))
|
||||||
|
(word-char? char) (recur (advance scanner) (str key char))
|
||||||
|
:else (add-error scanner (str "Unexpected " char "after keyword :" key))))))
|
||||||
|
|
||||||
|
;; TODO: improve number parsing?
|
||||||
|
;; Currently this uses Clojure's number formatting rules (since we use the EDN reader)
|
||||||
|
;; These rules are here: https://cljs.github.io/api/syntax/number
|
||||||
|
(defn- add-number [char scanner]
|
||||||
|
(loop [scanner scanner
|
||||||
|
num (str char)
|
||||||
|
float? false]
|
||||||
|
(let [curr (current-char scanner)]
|
||||||
|
(cond
|
||||||
|
(= curr \_) (recur (advance scanner) num float?) ;; consume underscores unharmed
|
||||||
|
(= curr \.) (if float?
|
||||||
|
(add-error scanner (str "Unexpected second decimal point after " num "."))
|
||||||
|
(recur (advance scanner) (str num curr) true))
|
||||||
|
(terminates? curr) (add-token scanner ::token/number (edn/read-string num))
|
||||||
|
(digit? curr) (recur (advance scanner) (str num curr) float?)
|
||||||
|
:else (add-error scanner (str "Unexpected " curr " after number " num "."))))))
|
||||||
|
|
||||||
|
;; TODO: add string interpolation
|
||||||
|
;; This still has to be devised
|
||||||
|
(defn- add-string
|
||||||
|
[scanner]
|
||||||
|
(loop [scanner scanner
|
||||||
|
string ""]
|
||||||
|
(let [char (current-char scanner)]
|
||||||
|
(case char
|
||||||
|
\newline (add-error scanner "Unterminated string.")
|
||||||
|
\" (add-token (advance scanner) ::token/string string)
|
||||||
|
\\ (let [next (next-char scanner)
|
||||||
|
scanner (if (= next \newline)
|
||||||
|
(update scanner ::line inc)
|
||||||
|
scanner)]
|
||||||
|
(recur (advance (advance scanner)) (str string next)))
|
||||||
|
(if (at-end? scanner)
|
||||||
|
(add-error scanner "Unterminated string.")
|
||||||
|
(recur (advance scanner) (str string char)))))))
|
||||||
|
|
||||||
|
(defn- add-word
|
||||||
|
[char scanner]
|
||||||
|
(loop [scanner scanner
|
||||||
|
word (str char)]
|
||||||
|
(let [curr (current-char scanner)]
|
||||||
|
(cond
|
||||||
|
(terminates? curr) (add-token scanner (get reserved-words word ::token/word))
|
||||||
|
(word-char? curr) (recur (advance scanner) (str word curr))
|
||||||
|
:else (add-error scanner (str "Unexpected " curr " after word " word "."))))))
|
||||||
|
|
||||||
|
(defn- add-ignored
|
||||||
|
[scanner]
|
||||||
|
(loop [scanner scanner
|
||||||
|
ignored "_"]
|
||||||
|
(let [char (current-char scanner)]
|
||||||
|
(cond
|
||||||
|
(terminates? char) (add-token scanner ::token/ignored)
|
||||||
|
(word-char? char) (recur (advance scanner) (str ignored char))
|
||||||
|
:else (add-error scanner (str "Unexpected " char " after word " ignored "."))))))
|
||||||
|
|
||||||
|
(defn- add-comment [char scanner]
|
||||||
|
(loop [scanner scanner
|
||||||
|
comm (str char)]
|
||||||
|
(let [char (current-char scanner)]
|
||||||
|
(if (= \newline char)
|
||||||
|
(update scanner ::line inc)
|
||||||
|
;;(if (s/starts-with? comm "&&&")
|
||||||
|
;;(add-token (update scanner ::line inc) ::token/docstring)
|
||||||
|
;;(add-token (update scanner ::line inc) ::token/comment))
|
||||||
|
(recur (advance scanner) (str comm char))))))
|
||||||
|
|
||||||
|
(defn- scan-token [scanner]
|
||||||
|
(let [char (current-char scanner)
|
||||||
|
scanner (advance scanner)
|
||||||
|
next (current-char scanner)]
|
||||||
|
(case char
|
||||||
|
;; one-character tokens
|
||||||
|
\( (add-token scanner ::token/lparen)
|
||||||
|
\) (add-token scanner ::token/rparen)
|
||||||
|
\{ (add-token scanner ::token/lbrace)
|
||||||
|
\} (add-token scanner ::token/rbrace)
|
||||||
|
\[ (add-token scanner ::token/lbracket)
|
||||||
|
\] (add-token scanner ::token/rbracket)
|
||||||
|
\; (add-token scanner ::token/semicolon)
|
||||||
|
\, (add-token scanner ::token/comma)
|
||||||
|
\newline (add-token (update scanner ::line inc) ::token/newline)
|
||||||
|
\\ (add-token scanner ::token/backslash)
|
||||||
|
\= (add-token scanner ::token/equals)
|
||||||
|
\> (add-token scanner ::token/pipeline)
|
||||||
|
|
||||||
|
;; two-character tokens
|
||||||
|
;; ->
|
||||||
|
\- (cond
|
||||||
|
(= next \>) (add-token (advance scanner) ::token/rarrow)
|
||||||
|
(digit? next) (add-number char scanner)
|
||||||
|
:else (add-error scanner (str "Expected -> or negative number. Got " char next)))
|
||||||
|
|
||||||
|
;; at current we're not using this
|
||||||
|
;; <-
|
||||||
|
\< (if (= next \-)
|
||||||
|
(add-token (advance scanner) ::token/larrow)
|
||||||
|
(add-error scanner (str "Expected <-. Got " char next)))
|
||||||
|
|
||||||
|
;; |>
|
||||||
|
;; Consider => , with =>> for bind
|
||||||
|
; \| (if (= next \>)
|
||||||
|
; (add-token (advance scanner) ::token/pipeline)
|
||||||
|
; (add-error scanner (str "Expected |>. Got " char next)))
|
||||||
|
|
||||||
|
;; possible additional operator: bind/result
|
||||||
|
;; possible additional operator: bind/some
|
||||||
|
;; oh god, monads
|
||||||
|
;; additional arrow possibilities: >> ||> ~> => !>
|
||||||
|
|
||||||
|
;; hashmap #{
|
||||||
|
\# (if (= next \{)
|
||||||
|
(add-token (advance scanner) ::token/starthash)
|
||||||
|
(add-error scanner (str "Expected beginning of hash: #{. Got " char next)))
|
||||||
|
|
||||||
|
;; set ${
|
||||||
|
\$ (if (= next \{)
|
||||||
|
(add-token (advance scanner) ::token/startset)
|
||||||
|
(add-error scanner (str "Expected beginning of set: ${. Got " char next)))
|
||||||
|
|
||||||
|
;; struct @{
|
||||||
|
\@ (if (= next \{)
|
||||||
|
(add-token (advance scanner) ::token/startstruct)
|
||||||
|
(add-error scanner (str "Expected beginning of struct: @{. Got " char next)))
|
||||||
|
|
||||||
|
;; placeholders
|
||||||
|
;; there's a flat _, and then ignored words
|
||||||
|
\_ (cond
|
||||||
|
(terminates? next) (add-token scanner ::token/placeholder)
|
||||||
|
(alpha? next) (add-ignored scanner)
|
||||||
|
:else (add-error scanner (str "Expected placeholder: _. Got " char next)))
|
||||||
|
|
||||||
|
;; comments
|
||||||
|
;; & starts an inline comment
|
||||||
|
;; TODO: include comments in scanned file
|
||||||
|
;; TODO, maybe: add doc comments: &&& (or perhaps a docstring in an fn?)
|
||||||
|
\& (add-comment char scanner)
|
||||||
|
|
||||||
|
;; keywords
|
||||||
|
\: (cond
|
||||||
|
(alpha? next) (add-keyword scanner)
|
||||||
|
:else (add-error scanner (str "Expected keyword. Got " char next)))
|
||||||
|
|
||||||
|
;; splats
|
||||||
|
\. (let [after_next (current-char (advance scanner))]
|
||||||
|
(if (= ".." (str next after_next))
|
||||||
|
(add-token (advance (advance scanner)) ::token/splat)
|
||||||
|
(add-error scanner (str "Expected splat: ... . Got " (str "." next after_next)))))
|
||||||
|
|
||||||
|
;; strings
|
||||||
|
\" (add-string scanner)
|
||||||
|
|
||||||
|
;; word matches
|
||||||
|
(cond
|
||||||
|
(whitespace? char) scanner ;; for now just skip whitespace characters
|
||||||
|
(digit? char) (add-number char scanner)
|
||||||
|
(alpha? char) (add-word char scanner)
|
||||||
|
:else (add-error scanner (str "Unexpected character: " char))))))
|
||||||
|
|
||||||
|
(defn- next-token [scanner]
|
||||||
|
(assoc scanner ::start (::current scanner)))
|
||||||
|
|
||||||
|
(defn scan [source]
|
||||||
|
(loop [scanner (new-scanner source)]
|
||||||
|
(if (at-end? scanner)
|
||||||
|
(let [scanner (add-token scanner ::token/eof)]
|
||||||
|
{:tokens (::tokens scanner)
|
||||||
|
:errors (::errors scanner)})
|
||||||
|
(recur (-> scanner (scan-token) (next-token))))))
|
||||||
|
|
||||||
|
(comment
|
||||||
|
(def source "@{")
|
||||||
|
|
||||||
|
(pp/pprint (scan source)))
|
53
src/ludus/show.cljc
Normal file
53
src/ludus/show.cljc
Normal file
|
@ -0,0 +1,53 @@
|
||||||
|
(ns ludus.show
|
||||||
|
(:require
|
||||||
|
[ludus.data :as data]
|
||||||
|
[clojure.pprint :as pp]))
|
||||||
|
|
||||||
|
(declare show show-linear show-keyed)
|
||||||
|
|
||||||
|
(defn- show-vector [v]
|
||||||
|
(if (= (first v) ::data/tuple)
|
||||||
|
(str "(" (apply str (into [] show-linear (next v))) ")")
|
||||||
|
(str "[" (apply str (into [] show-linear v)) "]")))
|
||||||
|
|
||||||
|
(defn- show-map [v]
|
||||||
|
(cond
|
||||||
|
(or (= (::data/type v) ::data/fn)
|
||||||
|
(= (::data/type v) ::data/clj))
|
||||||
|
(str "fn " (:name v))
|
||||||
|
|
||||||
|
(= (::data/type v) ::data/ns)
|
||||||
|
(str "ns " (::data/name v) " {"
|
||||||
|
(apply str (into [] show-keyed (dissoc v ::data/struct ::data/type ::data/name)))
|
||||||
|
"}")
|
||||||
|
|
||||||
|
(::data/struct v)
|
||||||
|
(str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}")
|
||||||
|
|
||||||
|
:else
|
||||||
|
(str "#{" (apply str (into [] show-keyed v)) "}")
|
||||||
|
|
||||||
|
))
|
||||||
|
|
||||||
|
(defn- show-set [v]
|
||||||
|
(str "${" (apply str (into [] show-linear v)) "}"))
|
||||||
|
|
||||||
|
(defn show [v]
|
||||||
|
(cond
|
||||||
|
(string? v) (str "\"" v "\"")
|
||||||
|
(number? v) (str v)
|
||||||
|
(keyword? v) (str v)
|
||||||
|
(boolean? v) (str v)
|
||||||
|
(nil? v) "nil"
|
||||||
|
(vector? v) (show-vector v)
|
||||||
|
(set? v) (show-set v)
|
||||||
|
(map? v) (show-map v)
|
||||||
|
:else (with-out-str (pp/pprint v))))
|
||||||
|
|
||||||
|
(def show-linear (comp (map show) (interpose ", ")))
|
||||||
|
|
||||||
|
(def show-keyed (comp
|
||||||
|
(map #(str (show (first %)) " " (show (second %))))
|
||||||
|
(interpose ", ")))
|
||||||
|
|
||||||
|
(show {::data/type ::data/fn :name "foo"})
|
11
src/ludus/token.cljc
Normal file
11
src/ludus/token.cljc
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
(ns ludus.token)
|
||||||
|
|
||||||
|
(defn token
|
||||||
|
([type text]
|
||||||
|
(token type text nil 1))
|
||||||
|
([type text literal line start]
|
||||||
|
{::type type
|
||||||
|
::lexeme text
|
||||||
|
::literal literal
|
||||||
|
::line line
|
||||||
|
::start start}))
|
Loading…
Reference in New Issue
Block a user