Pull janet files out into their own dir; start work on parser

This commit is contained in:
Scott Richmond 2024-01-07 22:59:00 -05:00
parent d3a1e10983
commit 70e8763dc5
3 changed files with 596 additions and 0 deletions

323
janet/parser.janet Normal file
View 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
View 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)])