twc/ludus
4
0
Fork 0
Code Issues 32 Pull Requests Packages Projects 8 Releases Wiki Activity

Broken! Argh.

Browse Source
This commit is contained in:
Scott Richmond 2023-05-16 20:54:01 -04:00
parent 52abde501a
commit a7ab313a5f
2 changed files with 231 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

212
src/ludus/grammar.clj Normal file
View File

@ -0,0 +1,212 @@
(ns ludus.grammar
(:require [ludus.parser-new :refer :all]
[ludus.scanner :as scan]))
(declare expression pattern)
(def separator (choice :separator [:comma :newline]))
(def terminator (choice :terminator [:newline :semicolon]))
(def nls? (quiet (zero+ :nls :newline)))
(def splat (group (order :splat [(quiet :splat) :word])))
(def splattern (group (order :splat [(quiet :splattern) (flat (choice :splatted [:word :ignored :placeholder]))])))
(def literal (flat (choice :literal [:nil :true :false :number :string])))
(def tuple-pat-term (choice :tuple-pat-term [pattern splattern]))
(def tuple-pat-entry (order :tuple-pat-enry [(quiet (one+ separator)) pattern]))
(def tuple-pat (group (order :tuple-pat
[(quiet :lparen)
(quiet (zero+ separator))
(maybe pattern)
(zero+ tuple-pat-entry)
(quiet (zero+ separator))
(quiet :rparen)])))
;; TODO: list, dict, struct patterns
(def pattern (choice :pattern [:literal :ignored :placeholder :word :keyword tuple-pat]))
(def iff (order :if [(quiet :if)
nls?
expression
nls?
(quiet :then)
expression
nls?
(quiet :else)
expression]))
(def cond-lhs (flat (choice :cond-lhs [expression :placeholder :else])))
(def cond-clause (group (order :cond-clause [cond-lhs (quiet :rarrow) expression])))
(def cond-entry (order :cond-entry [(quiet (one+ terminator)) cond-clause]))
(def condd (order :cond [(quiet :cond) (quiet :lbrace)
(quiet (zero+ terminator))
cond-clause
(zero+ cond-entry)
(quiet (zero+ terminator))
(quiet :rbrace)]))
(def lett (order :let [(quiet :let)
pattern
(quiet :equals)
nls?
expression]))
(def tuple-entry (order :tuple-entry [(quiet (one+ separator)) expression]))
(def tuple (order :tuple
[(quiet :lparen)
(quiet (zero+ separator))
(maybe expression)
(zero+ tuple-entry)
(quiet (zero+ separator))
(quiet :rparen)]))
(def list-term (flat (choice :list-term [splat expression])))
(def list-entry (order :list-entry [(quiet (one+ separator)) list-term]))
(def listt (order :list
[(quiet :lbracket)
(quiet (zero+ separator))
(maybe list-term)
(zero+ list-entry)
(quiet (zero+ separator))
(quiet :rbracket)]))
(def pair (group (order :pair [:keyword expression])))
(def struct-term (flat (choice :struct-term [:word pair])))
(def struct-entry (order :struct-entry [(quiet (one+ separator)) struct-term]))
(def structt (order :struct
[(quiet :startstruct)
(quiet (zero+ separator))
(maybe struct-term)
(zero+ struct-entry)
(quiet (zero+ separator))
(quiet :rbrace)]))
(def dict-term (flat (choice :dict-term [:word pair splat])))
(def dict-entry (order :dict-entry [(quiet (one+ separator)) dict-term]))
(def dict (order :dict
[(quiet :startdict)
(quiet (zero+ separator))
(maybe dict-term)
(zero+ dict-entry)
(quiet (zero+ separator))
(quiet :rbrace)]))
(def arg-expr (flat (choice :arg-expr [:placeholder expression])))
(def arg-entry (order :arg-entry [(quiet (one+ separator)) arg-expr]))
(def arg-tuple (order :arg-tuple
[(quiet :lparen)
(quiet (zero+ separator))
(maybe arg-expr)
(zero+ arg-entry)
(quiet (zero+ separator))
(quiet :rparen)]))
(def synth-root (choice :synth-root [:keyword :word :recur]))
(def synth-term (choice :synth-term [arg-tuple :keyword]))
(def synthetic (order :synthetic [synth-root (zero+ synth-term)]))
(def fn-clause (group (order :fn-clause [tuple-pat (quiet :rarrow) expression])))
(def fn-entry (order :fn-entry [(quiet (one+ terminator)) fn-clause]))
(def compound (group (order :compound [(quiet :lbrace)
(maybe :string)
fn-clause
(zero+ fn-entry)
nls?
(quiet :rbrace)
])))
(def clauses (flat (choice :clauses [compound fn-clause])))
(def named (group (order :named [:word clauses])))
(def body (flat (choice :body [fn-clause named])))
(def fnn (group (order :fn [(quiet :fn) body])))
(def block-line (order :block-line [(quiet terminator) expression]))
(def block (group (order :block [(quiet :lbrace) nls? expression (zero+ block-line) nls? (quiet :rbrace)])))
(def expression (flat (choice :expression [fnn lett iff condd synthetic block structt listt tuple literal])))
(def importt (group (order :import [(quiet :import) :string (quiet :as) :word])))
(def nss (group (order :nss [(quiet :ns)
:word
(quiet :lbrace)
(quiet (zero+ separator))
(maybe struct-term)
(zero+ struct-entry)
(quiet (zero+ separator))
(quiet :rbrace)])))
(def toplevel (flat (choice :toplevel [importt nss expression])))
(def script-line (order :script-line [(quiet (one+ terminator)) toplevel]))
(def script (order :script [nls? toplevel (zero+ script-line) nls? (quiet :eof)]))
;;;;;;;;;;;;;;;; REPL CRUFT
(def eg (:tokens (scan/scan
"
add (1, 2)
fn foo { (_) -> (1, 2) }"
)))
(def result (apply-parser script eg))
(defn report [node]
(when (fail? node) (err-msg node))
node)
(defn clean [node]
(if (map? node)
(-> node
(report)
(dissoc
:status
:remaining
:token)
(update :data #(into [] (map clean) %)))
node))
(defn tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x)
(def my-data (-> result clean tap))
my-data
(def my-first (-> my-data first))
(def my-sec (map :data (-> my-data second :data)))
(concat my-first my-sec)

143
src/ludus/parser-new.clj → src/ludus/parser_new.clj
View File

@ -1,6 +1,4 @@
(ns ludus.parser-new
(:require
[ludus.scanner :as scan]))
(ns ludus.parser-new)
(defn ? [val default] (if (nil? val) default val))
@ -30,7 +28,6 @@
(defn apply-kw-parser [kw tokens]
(let [token (first tokens)]
;(println "applying kw parser " kw " to " token)
(if (= kw (:type token))
{:status :ok
:type kw
@ -40,8 +37,7 @@
{:status :none :token token :trace [kw] :remaining (rest tokens)})))
(defn apply-fn-parser [parser tokens]
(let [rule (:rule parser) name (:name parser)]
;(println "appying fn parser " name " to " (first tokens))
(let [rule (:rule parser) name (:name parser)]
(rule tokens)))
(defn apply-parser [parser tokens]
@ -53,13 +49,12 @@
(defn choice [name parsers]
{:name name
:rule (fn choice-fn [tokens]
;(println "entering CHOICE" name)
(loop [ps parsers]
(let [result (apply-parser (first ps) tokens)
rem-ts (remaining result)
rem-ps (rest ps)]
(cond
(pass? result) ;result
(pass? result)
{:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts}
(= :err (:status result))
@ -72,8 +67,7 @@
(defn order [name parsers]
{:name name
:rule (fn order-fn [tokens]
;(println "entering ORDER" name)
:rule (fn order-fn [tokens]
(let [origin (first tokens)
first-result (apply-parser (first parsers) tokens)]
(case (:status first-result)
@ -137,15 +131,14 @@
([name parser]
{:name (kw+str name "-zero+")
:rule (fn zero+fn [tokens]
;(println "entering ZERO+")
(loop [results []
ts tokens]
;(println "looping ZERO+" (? (:name parser) parser))
(let [result (apply-parser parser ts)]
(case (:status result)
:ok (recur (conj results result) (remaining result))
:group (recur (vec (concat results (:data result))) (remaining result))
:quiet (recur results (remaining result))
:err (update result :trace #(conj % name))
{:status :group :type name :data results :token (first tokens) :remaining ts}))))}))
(defn one+
@ -193,6 +186,20 @@
(let [result (apply-parser parser tokens)]
(if (pass? result) (first (:data result)) 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 (:status result))
(assoc result :status :ok)
result)))}))
(defn err-msg [{token :token trace :trace}]
(println "Unexpected token " (:type token) " on line " (:line token))
(println "Expected token " (first trace)))
(comment
"
If I'm not mistaken, the Ludus grammer requires *no* lookahead, the first token in an expression tells you what kind of expression it is:
@ -225,115 +232,3 @@
")
(declare expression)
(def literal (flat (choice :literal [:nil :true :false :number :string])))
(def separator (choice :separator [:comma :newline]))
(def nls? (quiet (zero+ :nls :newline)))
(def pattern (choice :pattern [:literal :word])) ;; stupid to start
(def iff (order :iff [
(quiet :if)
nls?
expression
nls?
(quiet :then)
expression
nls?
(quiet :else)
expression]))
(def lett (order :let [
(quiet :let)
pattern
(quiet :equals)
nls?
expression]))
(def tuple-entry (order :tuple-entry [(quiet (one+ separator)) expression]))
(def tuple (order :tuple
[(quiet :lparen)
(quiet (zero+ separator))
(maybe expression)
(zero+ tuple-entry)
(quiet (zero+ separator))
(quiet :rparen)]))
(def splat (order :splat [(quiet :splat) :word]))
(def list-term (flat (choice :list-term [splat expression])))
(def list-entry (order :list-entry [(quiet (one+ separator)) list-term]))
(def listt (order :list
[(quiet :lbracket)
(quiet (zero+ separator))
(maybe list-term)
(zero+ list-entry)
(quiet (zero+ separator))
(quiet :rbracket)]))
(def synth-root (choice :synth-root [:keyword :word]))
(def synth-term (choice :synth-term [tuple :keyword]))
(def synthetic (order :synthetic [synth-root (zero+ synth-term)]))
(def terminator (choice :terminator [:newline :semicolon]))
(def block-line (order :block-line [(quiet terminator) expression]))
(def block (order :block [(quiet :lbrace) nls? expression (zero+ block-line) nls? (quiet :rbrace)]))
(def expression (choice :expression [lett iff synthetic block listt tuple literal]))
(def importt (order :import [(quiet :import) :string (quiet :as) :word]))
(def toplevel (flat (choice :toplevel [importt expression])))
(def script-line (order :script-line [(quiet terminator) toplevel]))
(def script (order :script [nls? toplevel (zero+ script-line) nls? (quiet :eof)]))
(def eg (:tokens (scan/scan
"1
2
3"
)))
eg
(println eg)
(def result (apply-parser script eg))
result
(println result)
(defn clean [node]
(if (map? node)
(-> node
(dissoc
:status
:remaining
:token)
(update :data #(into [] (map clean) %)))
node))
(defn tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x)
(def my-data (-> result clean tap))
my-data
(def my-first (-> my-data first))
(def my-sec (map :data (-> my-data second :data)))
(concat my-first my-sec)