Pull janet files out into their own dir; start work on parser
This commit is contained in:
Scott Richmond
parent
d3a1e10983
commit
70e8763dc5
323
janet/parser.janet
Normal file
323
janet/parser.janet
Normal file
|
|
@ -0,0 +1,323 @@
|
|||
(defn ? [val default] (if (nil? val) default val))
|
||||
|
||||
(defn ok? [{:status status}]
|
||||
(= status :ok))
|
||||
|
||||
(def failing {:err true :none true})
|
||||
|
||||
(def passing {:ok true :group true :quiet true})
|
||||
|
||||
(defn pass? [{:status status}] (get passing status))
|
||||
|
||||
(defn fail? [{:status status}] (get failing status))
|
||||
|
||||
(defn data [{:data d}] d)
|
||||
|
||||
(defn remaining [{:remaining r}] r)
|
||||
|
||||
(defn pname [parser] (? (get parser :name) parser))
|
||||
|
||||
(defn kw+str [kw mystr] (keyword (string kw) mystr))
|
||||
|
||||
(defn value [token]
|
||||
(if (= :none (get token :literal)) (get token :lexeme) (get token :literal)))
|
||||
|
||||
(defn rest [seq]
|
||||
(let [len (length seq)]
|
||||
(cond
|
||||
(empty? seq) []
|
||||
(tuple? seq) (tuple/slice 1 len)
|
||||
(array? seq) (array/slice 1 len))))
|
||||
|
||||
(defn some? [val] (not (nil? val)))
|
||||
|
||||
(defn apply-kw-parser [kw tokens]
|
||||
(let [token (first tokens)]
|
||||
#(if (= kw (get token :type)) (println "Matched " kw))
|
||||
(if (= kw (get token :type))
|
||||
{:status :ok
|
||||
:type kw
|
||||
:data (if (some? (value token)) [(value token)] [])
|
||||
:token token
|
||||
:remaining (rest tokens)}
|
||||
{:status :none :token token :trace [kw] :remaining (rest tokens)})))
|
||||
|
||||
(defn apply-fn-parser [parser tokens]
|
||||
(let [rule (get parser :rule) name (get parser :name) result (rule tokens)]
|
||||
#(if (pass? result) (println "Matched " (get parser :name)))
|
||||
result))
|
||||
|
||||
(defn apply-parser [parser tokens]
|
||||
#(println "Applying parser " (? (get parser :name) parser))
|
||||
(let [result (cond
|
||||
(keyword? parser) (apply-kw-parser parser tokens)
|
||||
(get parser :rule) (apply-fn-parser parser tokens)
|
||||
(function? parser) (apply-fn-parser (parser) tokens)
|
||||
:else (error "`apply-parser` requires a parser"))]
|
||||
#(println "Parser result " (? (get parser :name) parser) (get result :status))
|
||||
result
|
||||
))
|
||||
|
||||
|
||||
(defn choice [name parsers]
|
||||
{:name name
|
||||
:rule (fn choice-fn [tokens]
|
||||
(defn recur [ps]
|
||||
(let [result (apply-parser (first ps) tokens)
|
||||
rem-ts (remaining result)
|
||||
rem-ps (rest ps)]
|
||||
(cond
|
||||
(pass? result)
|
||||
{:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts}
|
||||
|
||||
(= :err (get result :status))
|
||||
(update result :trace |(array/push $ name))
|
||||
|
||||
(empty? rem-ps)
|
||||
{:status :none :token (first tokens) :trace [name] :remaining rem-ts}
|
||||
|
||||
:else (recur rem-ps))))
|
||||
|
||||
(recur parsers))})
|
||||
|
||||
(defn order-1 [name parsers]
|
||||
{:name name
|
||||
:rule (fn order-fn [tokens]
|
||||
(let [origin (first tokens)
|
||||
first-result (apply-parser (first parsers) tokens)]
|
||||
(case (get first-result :status)
|
||||
(:err :none)
|
||||
(put (update first-result :trace |(array/push $ name)) :status :none)
|
||||
|
||||
(:ok :quiet :group)
|
||||
(do (defn recur [ps results ts]
|
||||
(let [result (apply-parser (first ps) ts)
|
||||
res-rem (remaining result)]
|
||||
(if (empty? (rest ps))
|
||||
(case (get result :status)
|
||||
:ok {:status :group
|
||||
:type name
|
||||
:data (array/push results result)
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:quiet {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:group {:status :group
|
||||
:type name
|
||||
:data (array/concat results (get result :data))
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
(:err :none)
|
||||
(put (update result :trace |(array/push $ name)) :status :err))
|
||||
|
||||
(case (get result :status)
|
||||
:ok (recur (rest ps) (array/push results result) res-rem)
|
||||
:group (recur (rest ps)
|
||||
(array/concat results (get result :data))
|
||||
res-rem)
|
||||
:quiet (recur (rest ps) results res-rem)
|
||||
|
||||
(:err :none)
|
||||
(put (update result :trace |(array/push $ name)) :status :err)))))
|
||||
(recur
|
||||
(get first-result :status)
|
||||
(case (get first-result :status) :ok [first-result] :quiet [] :group (get first-result :data))
|
||||
(remaining first-result))))))})
|
||||
|
||||
(defn order-0 [name parsers]
|
||||
{:name name
|
||||
:rule (fn order-fn [tokens]
|
||||
(let [origin (first tokens)]
|
||||
(defn recur [ps results ts]
|
||||
(let [result (apply-parser (first ps) ts)
|
||||
res-rem (remaining result)]
|
||||
(if (empty? (rest ps))
|
||||
## Nothing more: return
|
||||
(case (get result :status)
|
||||
:ok {:status :group
|
||||
:type name
|
||||
:data (array/push results result)
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:quiet {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:group {:status :group
|
||||
:type name
|
||||
:data (array/concat results (get result :data))
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
(:err :none)
|
||||
(put (update result :trace |(array/push $ name)) :status :err))
|
||||
|
||||
## Still parsers left in the vector: recur
|
||||
(case (get result :status)
|
||||
:ok (recur (rest ps) (array/push results result) res-rem)
|
||||
:group (recur (rest ps)
|
||||
(array/concat results (get result :data))
|
||||
res-rem)
|
||||
:quiet (recur (rest ps) results res-rem)
|
||||
|
||||
(:err :none)
|
||||
(put (update result :trace |(array/push $ name)) :status :err)
|
||||
|
||||
(error (string "Got bad result: " (get result :status)))))))
|
||||
(recur parsers [] tokens)))})
|
||||
|
||||
#### Start here
|
||||
(defn weak-order [name parsers]
|
||||
{:name name
|
||||
:rule (fn order-fn [tokens]
|
||||
(let [origin (first tokens)]
|
||||
(loop [ps parsers
|
||||
results []
|
||||
ts tokens]
|
||||
(let [result (apply-parser (first ps) ts)
|
||||
res-rem (remaining result)]
|
||||
(if (empty? (rest ps))
|
||||
## Nothing more: return
|
||||
(case (get result :status)
|
||||
:ok {:status :group
|
||||
:type name
|
||||
:data (array/push results result)
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:quiet {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:group {:status :group
|
||||
:type name
|
||||
:data (array/concat results (get result :data))
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
(:err :none)
|
||||
(update result :trace |(array/push $ name)))
|
||||
|
||||
## Still parsers left in the vector: recur
|
||||
(case (get result :status)
|
||||
:ok (recur (rest ps) (array/push results result) res-rem)
|
||||
:group (recur (rest ps)
|
||||
(array/concat results (get result :data))
|
||||
res-rem)
|
||||
:quiet (recur (rest ps) results res-rem)
|
||||
|
||||
(:err :none)
|
||||
(update result :trace |(array/push $ name))))))))})
|
||||
|
||||
|
||||
(defn quiet [parser]
|
||||
{:name (kw+str (? (get parser :name) parser) "-quiet")
|
||||
:rule (fn quiet-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (pass? result)
|
||||
(assoc result :status :quiet)
|
||||
result)))})
|
||||
|
||||
(defn zero+
|
||||
([parser] (zero+ (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-zero+")
|
||||
:rule (fn zero+fn [tokens]
|
||||
(loop [results []
|
||||
ts tokens]
|
||||
(let [result (apply-parser parser ts)]
|
||||
(case (get result :status)
|
||||
:ok (recur (array/push results result) (remaining result))
|
||||
:group (recur (array/concat results (get result :data)) (remaining result))
|
||||
:quiet (recur results (remaining result))
|
||||
:err (update result :trace |(array/push $ name))
|
||||
:none {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token (first tokens)
|
||||
:remaining ts}))))}))
|
||||
|
||||
(defn one+
|
||||
([parser] (one+ (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-one+")
|
||||
:rule (fn one+fn [tokens]
|
||||
(let [first-result (apply-parser parser tokens)
|
||||
rest-parser (zero+ name parser)]
|
||||
(case (get first-result :status)
|
||||
(:ok :group)
|
||||
(let [rest-result (apply-parser rest-parser (remaining first-result))]
|
||||
(case (get rest-result :status)
|
||||
|
||||
(:ok :group :quiet)
|
||||
{:status :group
|
||||
:type name
|
||||
:data (array/concat (get first-result :data) (data rest-result))
|
||||
:token (first tokens)
|
||||
:remaining (remaining rest-result)}
|
||||
|
||||
:none {:status :group :type name
|
||||
:data first-result
|
||||
:token (first tokens)
|
||||
:remaining (remaining rest-result)}
|
||||
|
||||
:err (update rest-result :trace |(array/push % name))))
|
||||
|
||||
:quiet
|
||||
(let [rest-result (apply-parser rest-parser (remaining first-result))]
|
||||
{:status :quiet
|
||||
:type name
|
||||
:data []
|
||||
:token (first tokens)
|
||||
:remaining (remaining rest-result)})
|
||||
|
||||
(:err :none) first-result)))}))
|
||||
|
||||
(defn maybe
|
||||
([parser] (maybe (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-maybe")
|
||||
:rule (fn maybe-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (pass? result)
|
||||
result
|
||||
{:status :group :type name :data [] :token (first tokens) :remaining tokens}
|
||||
)))}))
|
||||
|
||||
(defn flat
|
||||
([parser] (flat (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-flat")
|
||||
:rule (fn flat-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (pass? result) (first (get result :data)) result)))}))
|
||||
|
||||
(defn group
|
||||
([parser] (group (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-group")
|
||||
:rule (fn group-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (= :group (get result :status))
|
||||
(assoc result :status :ok)
|
||||
result)))}))
|
||||
|
||||
(defn err-msg [{token :token trace :trace}]
|
||||
(println "Unexpected token " (get token :type) " on line " (get token :line))
|
||||
(println "Expected token " (first trace)))
|
||||
|
||||
(defmacro defp [name & items]
|
||||
(let [arg (last items)
|
||||
fns (into [] (butlast items))]
|
||||
`(defn ~name [] ((apply comp ~fns) (keyword '~name) ~arg))))
|
||||
273
src/ludus/grammar.janet
Normal file
273
src/ludus/grammar.janet
Normal file
|
|
@ -0,0 +1,273 @@
|
|||
(ns ludus.grammar
|
||||
(:require
|
||||
#?(
|
||||
:clj [ludus.parser :refer :all]
|
||||
:cljs [ludus.parser
|
||||
:refer [choice quiet one+ zero+ group order-0 order-1 flat maybe weak-order]
|
||||
:refer-macros [defp]
|
||||
]
|
||||
)
|
||||
[ludus.scanner :as s]
|
||||
))
|
||||
|
||||
(declare expression pattern binding-expr non-binding simple)
|
||||
|
||||
(defp separator choice [:comma :newline :break])
|
||||
|
||||
(defp separators quiet one+ separator)
|
||||
|
||||
(defp terminator choice [:newline :semicolon :break])
|
||||
|
||||
(defp terminators quiet one+ terminator)
|
||||
|
||||
(defp nls? quiet zero+ :newline)
|
||||
|
||||
(defp splat group order-1 [(quiet :splat) :word])
|
||||
|
||||
(defp patt-splat-able flat choice [:word :ignored :placeholder])
|
||||
|
||||
(defp splattern group order-1 [(quiet :splat) (maybe patt-splat-able)])
|
||||
|
||||
(defp literal flat choice [:nil :true :false :number :string])
|
||||
|
||||
(defp tuple-pattern-term flat choice [pattern splattern])
|
||||
|
||||
(defp tuple-pattern-entry weak-order [tuple-pattern-term separators])
|
||||
|
||||
(defp tuple-pattern group order-1 [(quiet :lparen)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ tuple-pattern-entry)
|
||||
(quiet :rparen)])
|
||||
|
||||
(defp list-pattern group order-1 [(quiet :lbracket)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ tuple-pattern-entry)
|
||||
(quiet :rbracket)])
|
||||
|
||||
(defp pair-pattern group weak-order [:keyword pattern])
|
||||
|
||||
(defp typed group weak-order [:word (quiet :as) :keyword])
|
||||
|
||||
(defp dict-pattern-term flat choice [pair-pattern typed :word splattern])
|
||||
|
||||
(defp dict-pattern-entry weak-order [dict-pattern-term separators])
|
||||
|
||||
(defp dict-pattern group order-1 [(quiet :startdict)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ dict-pattern-entry)
|
||||
(quiet :rbrace)
|
||||
])
|
||||
|
||||
; (defp struct-pattern group order-1 [(quiet :startstruct)
|
||||
; (quiet (zero+ separator))
|
||||
; (zero+ dict-pattern-entry)
|
||||
; (quiet :rbrace)
|
||||
; ])
|
||||
|
||||
(defp guard order-0 [(quiet :if) simple])
|
||||
|
||||
(defp pattern flat choice [literal
|
||||
:ignored
|
||||
:placeholder
|
||||
typed
|
||||
:word
|
||||
:keyword
|
||||
:else
|
||||
tuple-pattern
|
||||
dict-pattern
|
||||
;struct-pattern
|
||||
list-pattern])
|
||||
|
||||
(defp match-clause group weak-order [pattern (maybe guard) (quiet :rarrow) expression])
|
||||
|
||||
(defp match-entry weak-order [match-clause terminators])
|
||||
|
||||
(defp match group order-1 [(quiet :match) simple nls?
|
||||
(quiet :with) (quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ match-entry)
|
||||
(quiet :rbrace)
|
||||
])
|
||||
|
||||
(defp when-lhs flat choice [simple :placeholder :else])
|
||||
|
||||
(defp when-clause group weak-order [when-lhs (quiet :rarrow) expression])
|
||||
|
||||
(defp when-entry weak-order [when-clause terminators])
|
||||
|
||||
(defp when-expr group order-1 [(quiet :when) (quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ when-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp let-expr group order-1 [(quiet :let)
|
||||
pattern
|
||||
(quiet :equals)
|
||||
nls?
|
||||
non-binding])
|
||||
|
||||
(defp condition flat choice [simple let-expr])
|
||||
|
||||
(defp if-expr group order-1 [(quiet :if)
|
||||
nls?
|
||||
condition
|
||||
nls?
|
||||
(quiet :then)
|
||||
expression
|
||||
nls?
|
||||
(quiet :else)
|
||||
expression])
|
||||
|
||||
(defp tuple-entry weak-order [non-binding separators])
|
||||
|
||||
(defp tuple group order-1 [(quiet :lparen)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ tuple-entry)
|
||||
(quiet :rparen)])
|
||||
|
||||
(defp list-term flat choice [splat non-binding])
|
||||
|
||||
(defp list-entry order-1 [list-term separators])
|
||||
|
||||
(defp list-literal group order-1 [(quiet :lbracket)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ list-entry)
|
||||
(quiet :rbracket)])
|
||||
|
||||
(defp set-literal group order-1 [(quiet :startset)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ list-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp pair group order-0 [:keyword non-binding])
|
||||
|
||||
;; "struct-term" and "struct-entry" are necessary for nses
|
||||
(defp struct-term flat choice [:word pair])
|
||||
|
||||
(defp struct-entry order-1 [struct-term separators])
|
||||
|
||||
; (defp struct-literal group order-1 [(quiet :startstruct)
|
||||
; (quiet (zero+ separator))
|
||||
; (zero+ struct-entry)
|
||||
; (quiet :rbrace)])
|
||||
|
||||
(defp dict-term flat choice [splat :word pair])
|
||||
|
||||
(defp dict-entry order-1 [dict-term separators])
|
||||
|
||||
(defp dict group order-1 [(quiet :startdict)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ dict-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp arg-expr flat choice [:placeholder non-binding])
|
||||
|
||||
(defp arg-entry weak-order [arg-expr separators])
|
||||
|
||||
(defp args group order-1 [(quiet :lparen)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ arg-entry)
|
||||
(quiet :rparen)])
|
||||
|
||||
(defp recur-call group order-1 [(quiet :recur) tuple])
|
||||
|
||||
(defp synth-root flat choice [:keyword :word])
|
||||
|
||||
(defp synth-term flat choice [args :keyword])
|
||||
|
||||
(defp synthetic group order-1 [synth-root (zero+ synth-term)])
|
||||
|
||||
(defp fn-clause group order-1 [tuple-pattern (maybe guard) (quiet :rarrow) expression])
|
||||
|
||||
(defp fn-entry order-1 [fn-clause terminators])
|
||||
|
||||
(defp fn-compound group order-1 [(quiet :lbrace)
|
||||
nls?
|
||||
(maybe :string)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ fn-entry)
|
||||
(quiet :rbrace)
|
||||
])
|
||||
|
||||
(defp clauses flat choice [fn-clause fn-compound])
|
||||
|
||||
(defp fn-named group order-1 [(quiet :fn) :word clauses])
|
||||
|
||||
(defp lambda group order-1 [(quiet :fn) fn-clause])
|
||||
|
||||
(defp block-line weak-order [expression terminators])
|
||||
|
||||
(defp block group order-1 [(quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ block-line)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp pipeline quiet order-0 [nls? :pipeline])
|
||||
|
||||
(defp do-entry order-1 [pipeline expression])
|
||||
|
||||
(defp do-expr group order-1 [(quiet :do)
|
||||
expression
|
||||
(one+ do-entry)
|
||||
])
|
||||
|
||||
(defp ref-expr group order-1 [(quiet :ref) :word (quiet :equals) expression])
|
||||
|
||||
; (defp spawn group order-1 [(quiet :spawn) expression])
|
||||
|
||||
; (defp receive group order-1 [(quiet :receive) (quiet :lbrace)
|
||||
; (quiet (zero+ terminator))
|
||||
; (one+ match-entry)
|
||||
; (quiet :rbrace)
|
||||
; ])
|
||||
|
||||
(defp compound-loop group order-0 [(quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ fn-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp loop-expr group order-1 [(quiet :loop) tuple (quiet :with)
|
||||
(flat (choice :loop-body [fn-clause compound-loop]))])
|
||||
|
||||
(defp repeat-expr group order-1 [(quiet :repeat) (choice :times [:word :number]) non-binding])
|
||||
|
||||
(defp collection flat choice [;struct-literal
|
||||
dict list-literal set-literal tuple])
|
||||
|
||||
(defp panic group order-1 [(quiet :panic) expression])
|
||||
|
||||
(defp simple flat choice [literal collection synthetic recur-call lambda panic])
|
||||
|
||||
(defp compound flat choice [match loop-expr if-expr when-expr do-expr block repeat-expr])
|
||||
|
||||
(defp binding-expr flat choice [fn-named let-expr ref-expr])
|
||||
|
||||
(defp non-binding flat choice [simple compound])
|
||||
|
||||
(defp expression flat choice [binding-expr non-binding])
|
||||
|
||||
(defp test-expr group order-1 [(quiet :test) :string non-binding])
|
||||
|
||||
(defp import-expr group order-1 [(quiet :import) :string (quiet :as) :word])
|
||||
|
||||
(defp ns-expr group order-1 [(quiet :ns)
|
||||
:word
|
||||
(quiet :lbrace)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ struct-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp use-expr group order-1 [(quiet :use) :word])
|
||||
|
||||
(defp toplevel flat choice [import-expr
|
||||
ns-expr
|
||||
expression
|
||||
test-expr
|
||||
use-expr])
|
||||
|
||||
(defp script-line weak-order [toplevel terminators])
|
||||
|
||||
(defp script order-0 [nls?
|
||||
(one+ script-line)
|
||||
(quiet :eof)])
|
||||
|
||||
Loading…
Reference in New Issue
Block a user