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

start integration work: comment out prints/pps; create ludus.janet

Browse Source
This commit is contained in:
Scott Richmond 2024-06-05 11:55:06 -04:00
parent fa5e298d94
commit 721594823d
5 changed files with 204 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
janet/interpreter.janet
View File

@ -1,7 +1,7 @@
# A tree walk interpreter for ludus # A tree walk interpreter for ludus
# for repl imports # for repl imports
(try (os/cd "janet") ([_] nil)) # (try (os/cd "janet") ([_] nil))
(import ./base :as b) (import ./base :as b)
@ -11,8 +11,8 @@
(defn- todo [msg] (error (string "not yet implemented: " msg))) (defn- todo [msg] (error (string "not yet implemented: " msg)))
(defn- resolve-name [name ctx] (defn- resolve-name [name ctx]
# (print "resolving " name " in:") # # (print "resolving " name " in:")
# (pp ctx) # # (pp ctx)
(when (not ctx) (break :^not-found)) (when (not ctx) (break :^not-found))
(if (has-key? ctx name) (if (has-key? ctx name)
(ctx name) (ctx name)
@ -20,7 +20,7 @@
(defn- match-word [word value ctx] (defn- match-word [word value ctx]
(def name (word :data)) (def name (word :data))
# (print "matched " (b/show value) " to " name) # # (print "matched " (b/show value) " to " name)
(set (ctx name) value) (set (ctx name) value)
{:success true :ctx ctx}) {:success true :ctx ctx})
@ -45,13 +45,13 @@
(def splat? (= :splat ((last members) :type))) (def splat? (= :splat ((last members) :type)))
(when splat? (when splat?
(when (< val-len patt-len) (when (< val-len patt-len)
(print "mismatched splatted tuple lengths") # (print "mismatched splatted tuple lengths")
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
(print "splat!") # (print "splat!")
(set splat (last members)) (set splat (last members))
(set members (slice members 0 (dec patt-len)))) (set members (slice members 0 (dec patt-len))))
(when (and (not splat?) (not= val-len patt-len)) (when (and (not splat?) (not= val-len patt-len))
(print "mismatched tuple lengths") # (print "mismatched tuple lengths")
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
(var curr-mem :^nothing) (var curr-mem :^nothing)
(var curr-val :^nothing) (var curr-val :^nothing)
@ -59,10 +59,10 @@
(for i 0 (length members) (for i 0 (length members)
(set curr-mem (get members i)) (set curr-mem (get members i))
(set curr-val (get value i)) (set curr-val (get value i))
(print "in tuple, matching " curr-val " with ") # (print "in tuple, matching " curr-val " with ")
(pp curr-mem) # (pp curr-mem)
(def match? (match-pattern curr-mem curr-val ctx)) (def match? (match-pattern curr-mem curr-val ctx))
(pp match?) # (pp match?)
(when (not (match? :success)) (when (not (match? :success))
(set success false) (set success false)
(break))) (break)))
@ -83,13 +83,13 @@
(def splat? (= :splat ((last members) :type))) (def splat? (= :splat ((last members) :type)))
(when splat? (when splat?
(when (< val-len patt-len) (when (< val-len patt-len)
(print "mismatched splatted list lengths") # (print "mismatched splatted list lengths")
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
(print "splat!") # (print "splat!")
(set splat (last members)) (set splat (last members))
(set members (slice members 0 (dec patt-len)))) (set members (slice members 0 (dec patt-len))))
(when (and (not splat?) (not= val-len patt-len)) (when (and (not splat?) (not= val-len patt-len))
(print "mismatched list lengths") # (print "mismatched list lengths")
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
(var curr-mem :^nothing) (var curr-mem :^nothing)
(var curr-val :^nothing) (var curr-val :^nothing)
@ -97,10 +97,10 @@
(for i 0 (length members) (for i 0 (length members)
(set curr-mem (get members i)) (set curr-mem (get members i))
(set curr-val (get value i)) (set curr-val (get value i))
(print "in list, matching " curr-val " with ") # (print "in list, matching " curr-val " with ")
(pp curr-mem) # (pp curr-mem)
(def match? (match-pattern curr-mem curr-val ctx)) (def match? (match-pattern curr-mem curr-val ctx))
(pp match?) # (pp match?)
(when (not (match? :success)) (when (not (match? :success))
(set success false) (set success false)
(break))) (break)))
@ -115,8 +115,8 @@
(when (not (string? value)) (when (not (string? value))
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
(def {:compiled compiled :bindings bindings} pattern) (def {:compiled compiled :bindings bindings} pattern)
(print "matching " value " with") # (print "matching " value " with")
(pp (pattern :grammar)) # (pp (pattern :grammar))
(def matches (peg/match compiled value)) (def matches (peg/match compiled value))
(when (not matches) (when (not matches)
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
@ -140,13 +140,13 @@
(def splat? (= :splat ((last members) :type))) (def splat? (= :splat ((last members) :type)))
(when splat? (when splat?
(when (< val-size patt-len) (when (< val-size patt-len)
(print "mismatched splatted dict lengths") # (print "mismatched splatted dict lengths")
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
(print "splat!") # (print "splat!")
(set splat (last members)) (set splat (last members))
(set members (slice members 0 (dec patt-len)))) (set members (slice members 0 (dec patt-len))))
(when (and (not splat?) (not= val-size patt-len)) (when (and (not splat?) (not= val-size patt-len))
(print "mismatched dict lengths") # (print "mismatched dict lengths")
(break {:success false :miss [pattern value]})) (break {:success false :miss [pattern value]}))
(var success true) (var success true)
(def matched-keys @[]) (def matched-keys @[])
@ -171,8 +171,8 @@
(defn- match-pattern* [pattern value &opt ctx] (defn- match-pattern* [pattern value &opt ctx]
(print "in match-pattern, matching " value " with:") # (print "in match-pattern, matching " value " with:")
(pp pattern) # (pp pattern)
(default ctx @{}) (default ctx @{})
(def data (pattern :data)) (def data (pattern :data))
(case (pattern :type) (case (pattern :type)
@ -328,10 +328,10 @@
(merge-into the-dict splatted)) (merge-into the-dict splatted))
(do (do
(def [key-ast value-ast] (member :data)) (def [key-ast value-ast] (member :data))
(print "dict key") # (print "dict key")
(pp key-ast) # (pp key-ast)
(print "dict value") # (print "dict value")
(pp value-ast) # (pp value-ast)
(def key (interpret key-ast ctx)) (def key (interpret key-ast ctx))
(def value (interpret value-ast ctx)) (def value (interpret value-ast ctx))
(set (the-dict key) value)))) (set (the-dict key) value))))
@ -360,19 +360,19 @@
# For now, this should be enough to tall the thing # For now, this should be enough to tall the thing
(defn- fnn [ast ctx] (defn- fnn [ast ctx]
(def {:name name :data clauses :doc doc} ast) (def {:name name :data clauses :doc doc} ast)
(print "defining fn " name) # (print "defining fn " name)
(def closure (table/to-struct ctx)) (def closure (table/to-struct ctx))
(def the-fn @{:name name :^type :fn :body clauses :ctx closure :doc doc}) (def the-fn @{:name name :^type :fn :body clauses :ctx closure :doc doc})
(when (not= :^not-found (resolve-name name ctx)) (when (not= :^not-found (resolve-name name ctx))
(print "fn "name" was forward declared") # (print "fn "name" was forward declared")
(def fwd (resolve-name name ctx)) (def fwd (resolve-name name ctx))
(set (fwd :body) clauses) (set (fwd :body) clauses)
(set (fwd :ctx) closure) (set (fwd :ctx) closure)
(set (fwd :doc) doc) (set (fwd :doc) doc)
(print "fn " name " has been defined") # (print "fn " name " has been defined")
(pp fwd) # (pp fwd)
(break fwd)) (break fwd))
(pp the-fn) # (pp the-fn)
(set (ctx name) the-fn) (set (ctx name) the-fn)
the-fn) the-fn)
@ -384,27 +384,27 @@
(eval ~(fn ,(symbol name) [] :foo)) (eval ~(fn ,(symbol name) [] :foo))
(defn- partial [the-fn partial-args] (defn- partial [the-fn partial-args]
(print "calling partially applied function") # (print "calling partially applied function")
(def args (partial-args :args)) (def args (partial-args :args))
(pp args) # (pp args)
(def pos (find-index is_placeholder args)) (def pos (find-index is_placeholder args))
(def name (string (the-fn :name) " *partial*")) (def name (string (the-fn :name) " *partial*"))
(defn partial-fn [missing] (defn partial-fn [missing]
(print "calling function with arg " (b/show missing)) # (print "calling function with arg " (b/show missing))
(pp partial-args) # (pp partial-args)
(def full-args (array/slice args)) (def full-args (array/slice args))
(set (full-args pos) missing) (set (full-args pos) missing)
(print "all args: " (b/show full-args)) # (print "all args: " (b/show full-args))
(call-fn the-fn [;full-args])) (call-fn the-fn [;full-args]))
{:^type :applied :name name :body partial-fn}) {:^type :applied :name name :body partial-fn})
(defn- call-fn* [the-fn args] (defn- call-fn* [the-fn args]
(print "calling " (b/show the-fn)) # (print "calling " (b/show the-fn))
(print "with args " (b/show args)) # (print "with args " (b/show args))
(when (or (when (or
(= :function (type the-fn)) (= :function (type the-fn))
(= :cfunction (type the-fn))) (= :cfunction (type the-fn)))
(print "Janet function") # (print "Janet function")
(break (the-fn ;args))) (break (the-fn ;args)))
(def clauses (the-fn :body)) (def clauses (the-fn :body))
(when (= :nothing clauses) (when (= :nothing clauses)
@ -420,11 +420,11 @@
(match-pattern patt args @{:^parent (the-fn :ctx)})) (match-pattern patt args @{:^parent (the-fn :ctx)}))
(when (not (match? :success)) (when (not (match? :success))
(break (match-fn (inc i) args))) (break (match-fn (inc i) args)))
(print "matched!") # (print "matched!")
(def body-ctx (match? :ctx)) (def body-ctx (match? :ctx))
(def guard? (if guard (def guard? (if guard
(b/bool (interpret guard body-ctx)) true)) (b/bool (interpret guard body-ctx)) true))
(print "passed guard") # (print "passed guard")
(when (not guard?) (when (not guard?)
(break (match-fn (inc i) args))) (break (match-fn (inc i) args)))
(interpret expr body-ctx)) (interpret expr body-ctx))
@ -436,11 +436,11 @@
(defn- call-partial [the-fn arg] ((the-fn :body) ;arg)) (defn- call-partial [the-fn arg] ((the-fn :body) ;arg))
(defn- apply-synth-term [prev curr] (defn- apply-synth-term [prev curr]
(print "applying " (b/show prev)) # (print "applying " (b/show prev))
(print "to" (b/show curr)) # (print "to" (b/show curr))
(def types [(b/ludus/type prev) (b/ludus/type curr)]) (def types [(b/ludus/type prev) (b/ludus/type curr)])
(print "typle:") # (print "typle:")
(pp types) # (pp types)
(match types (match types
[:fn :tuple] (call-fn prev curr) [:fn :tuple] (call-fn prev curr)
[:fn :partial] (partial prev curr) [:fn :partial] (partial prev curr)
@ -454,19 +454,19 @@
(defn- synthetic [ast ctx] (defn- synthetic [ast ctx]
(def terms (ast :data)) (def terms (ast :data))
(print "interpreting synthetic") # (print "interpreting synthetic")
(pp ast) # (pp ast)
(pp terms) # (pp terms)
(def first-term (first terms)) (def first-term (first terms))
(def last-term (last terms)) (def last-term (last terms))
(var prev (interpret first-term ctx)) (var prev (interpret first-term ctx))
(print "root term: ") # (print "root term: ")
(pp prev) # (pp prev)
(for i 1 (-> terms length dec) (for i 1 (-> terms length dec)
(def curr (interpret (terms i) ctx)) (def curr (interpret (terms i) ctx))
(print "term " i ": " curr) # (print "term " i ": " curr)
(set prev (apply-synth-term prev curr))) (set prev (apply-synth-term prev curr)))
(print "done with inner terms, applying last term") # (print "done with inner terms, applying last term")
(apply-synth-term prev (interpret last-term ctx))) (apply-synth-term prev (interpret last-term ctx)))
(defn- doo [ast ctx] (defn- doo [ast ctx]
@ -487,13 +487,13 @@
(def key (interpret key-ast ctx)) (def key (interpret key-ast ctx))
(def value (interpret value-ast ctx)) (def value (interpret value-ast ctx))
(set (the-pkg key) value)) (set (the-pkg key) value))
(pp the-pkg) # (pp the-pkg)
(def out (table/to-struct the-pkg)) (def out (table/to-struct the-pkg))
(set (ctx (ast :name)) out) (set (ctx (ast :name)) out)
out) out)
(defn- loopp [ast ctx] (defn- loopp [ast ctx]
(print "looping!") # (print "looping!")
(def data (ast :data)) (def data (ast :data))
(def args (interpret (data 0) ctx)) (def args (interpret (data 0) ctx))
(when (ast :match) (break ((ast :match) 0 args))) (when (ast :match) (break ((ast :match) 0 args)))
@ -501,8 +501,8 @@
(def len (length clauses)) (def len (length clauses))
(def loop-ctx @{:^parent ctx}) (def loop-ctx @{:^parent ctx})
(defn match-fn [i args] (defn match-fn [i args]
(print "calling inner loop fn") # (print "calling inner loop fn")
(print "for the " i "th time") # (print "for the " i "th time")
(when (= len i) (when (= len i)
(error {:node ast :value args :msg "no match"})) (error {:node ast :value args :msg "no match"}))
(def clause (clauses i)) (def clause (clauses i))
@ -510,30 +510,30 @@
(def match? (def match?
(match-pattern patt args loop-ctx)) (match-pattern patt args loop-ctx))
(when (not (match? :success)) (when (not (match? :success))
(print "no match") # (print "no match")
(break (match-fn (inc i) args))) (break (match-fn (inc i) args)))
(print "matched!") # (print "matched!")
(def body-ctx (match? :ctx)) (def body-ctx (match? :ctx))
(def guard? (if guard (def guard? (if guard
(b/bool (interpret guard body-ctx)) true)) (b/bool (interpret guard body-ctx)) true))
(print "passed guard") # (print "passed guard")
(when (not guard?) (when (not guard?)
(break (match-fn (inc i) args))) (break (match-fn (inc i) args)))
(interpret expr body-ctx)) (interpret expr body-ctx))
(set (ast :match) match-fn) (set (ast :match) match-fn)
(set (loop-ctx :^recur) match-fn) (set (loop-ctx :^recur) match-fn)
(print "ATTACHED MATCH-FN") # (print "ATTACHED MATCH-FN")
(match-fn 0 args)) (match-fn 0 args))
(defn- recur [ast ctx] (defn- recur [ast ctx]
(print "recurring!") # (print "recurring!")
(def passed (ast :data)) (def passed (ast :data))
(def args (interpret passed ctx)) (def args (interpret passed ctx))
(def match-fn (resolve-name :^recur ctx)) (def match-fn (resolve-name :^recur ctx))
(print "match fn in ctx:") # (print "match fn in ctx:")
(pp (ctx :^recur)) # (pp (ctx :^recur))
(pp match-fn) # (pp match-fn)
(pp ctx) # (pp ctx)
(match-fn 0 args)) (match-fn 0 args))
# TODO for 0.1.0 # TODO for 0.1.0
@ -548,7 +548,7 @@
(defn- usee [ast ctx] (todo "use")) (defn- usee [ast ctx] (todo "use"))
(defn- interpret* [ast ctx] (defn- interpret* [ast ctx]
(print "interpreting node " (ast :type)) # (print "interpreting node " (ast :type))
(case (ast :type) (case (ast :type)
# literals # literals
:nil :^nil :nil :^nil
@ -625,12 +625,10 @@
(def validated (v/valid parsed b/ctx)) (def validated (v/valid parsed b/ctx))
# (when (has-errors? validated) (break (validated :errors))) # (when (has-errors? validated) (break (validated :errors)))
# (def cleaned (get-in parsed [:ast :data 1])) # (def cleaned (get-in parsed [:ast :data 1]))
# (pp cleaned) # # (pp cleaned)
# (interpret (parsed :ast) @{:^parent b/ctx}) # (interpret (parsed :ast) @{:^parent b/ctx})
(try (interpret (parsed :ast) @{:^parent b/ctx}) (try (interpret (parsed :ast) @{:^parent b/ctx})
([e] (print "Ludus panicked!: " ([e] (if (struct? e) (error (e :msg)) (error e)))))
(if (struct? e) (error (e :msg)) (error e)))))
)
(do (do
(set source ` (set source `

40
janet/ludus.janet Normal file
View File

@ -0,0 +1,40 @@
# an integrated Ludus interpreter
(try (os/cd "janet") ([_] nil)) # for REPL
(import ./scanner :as s)
(import ./parser :as p)
(import ./validate :as v)
(import ./interpreter :as i)
# (defn run []
# (def scanned (s/scan source))
# (when (has-errors? scanned) (break (scanned :errors)))
# (def parsed (p/parse scanned))
# (when (has-errors? parsed) (break (parsed :errors)))
# (def validated (v/valid parsed b/ctx))
# # (when (has-errors? validated) (break (validated :errors)))
# # (def cleaned (get-in parsed [:ast :data 1]))
# # # (pp cleaned)
# # (interpret (parsed :ast) @{:^parent b/ctx})
# (try (interpret (parsed :ast) @{:^parent b/ctx})
# ([e] (if (struct? e) (error (e :msg)) (error e)))))
(defn main [source]
(def scanned (s/scan source))
(when (any? (scanned :errors))
(break (scanned :errors)))
(def parsed (p/parse scanned))
(when (any? (parsed :errors))
(break (parsed :errors)))
(def validated (v/valid parsed))
(when (any? (validated :errors))
(break (validated :errors)))
(try
(i/interpret (parsed :ast) @{})
([e] (if (struct? e) (error (e :msg)) (error e)))))
(def source `
fn foo () -> :foo
fool ()
`)
(main source)

81
janet/parser.janet
View File

@ -1,7 +1,7 @@
### A recursive descent parser for Ludus ### A recursive descent parser for Ludus
### We still need to scan some things ### We still need to scan some things
(try (os/cd "janet") ([_] nil)) # when in repl to do relative imports # (try (os/cd "janet") ([_] nil)) # when in repl to do relative imports
(import ./scanner :as s) (import ./scanner :as s)
(defmacro declare (defmacro declare
@ -88,7 +88,7 @@
(defn- panic (defn- panic
"Panics the parser: starts skipping tokens until a breaking token is encountered. Adds the error to the parser's errors array, and also errors out." "Panics the parser: starts skipping tokens until a breaking token is encountered. Adds the error to the parser's errors array, and also errors out."
[parser message] [parser message]
(print "Panic in the parser: " message) # (print "Panic in the parser: " message)
(def origin (current parser)) (def origin (current parser))
(advance parser) (advance parser)
(def skipped @[origin]) (def skipped @[origin])
@ -183,13 +183,13 @@
# interpolated strings, which are a whole other scene # interpolated strings, which are a whole other scene
(defn- scan-interpolations [data] (defn- scan-interpolations [data]
(print "scanning interpolation: " data) # (print "scanning interpolation: " data)
(when (buffer? data) (break data)) (when (buffer? data) (break data))
(pp data) # (pp data)
(def to-scan (data :to-scan)) (def to-scan (data :to-scan))
(def {:tokens tokens :errors errors} (s/scan to-scan)) (def {:tokens tokens :errors errors} (s/scan to-scan))
(pp tokens) # (pp tokens)
(print "there are " (length tokens) " tokens") # (print "there are " (length tokens) " tokens")
(def first-token (first tokens)) (def first-token (first tokens))
(cond (cond
(first errors) (first errors) (first errors) (first errors)
@ -301,12 +301,12 @@
(capture nonbinding parser))) (capture nonbinding parser)))
(array/push (ast :data) term) (array/push (ast :data) term)
(try (separators parser) (try (separators parser)
([e] (pp e) (array/push (ast :data) e)))) ([e] (array/push (ast :data) e))))
(advance parser) (advance parser)
ast) ast)
(defn- synth-root [parser] (defn- synth-root [parser]
(print "parsing synth root") # (print "parsing synth root")
(def origin (current parser)) (def origin (current parser))
(advance parser) (advance parser)
(case (type origin) (case (type origin)
@ -318,7 +318,7 @@
) )
(defrec synthetic [parser] (defrec synthetic [parser]
(print "parsing synthetic") # (print "parsing synthetic")
(def origin (current parser)) (def origin (current parser))
# (def ast {:type :synthetic :data @[(synth-root parser)] :token origin}) # (def ast {:type :synthetic :data @[(synth-root parser)] :token origin})
(def terms @[(synth-root parser)]) (def terms @[(synth-root parser)])
@ -347,7 +347,7 @@
(def term (capture nonbinding parser)) (def term (capture nonbinding parser))
(array/push (ast :data) term) (array/push (ast :data) term)
(try (separators parser) (try (separators parser)
([e] (pp e) (array/push (ast :data) e)))) ([e] (array/push (ast :data) e))))
(advance parser) (advance parser)
ast) ast)
@ -468,7 +468,7 @@
(capture pattern parser))) (capture pattern parser)))
(array/push (ast :data) term) (array/push (ast :data) term)
(try (separators parser) (try (separators parser)
([e] (pp e) (array/push (ast :data) e)))) ([e] (array/push (ast :data) e))))
(advance parser) (advance parser)
ast) ast)
@ -711,20 +711,20 @@
### function forms ### function forms
(defn- fn-simple [parser] (defn- fn-simple [parser]
(print "parsing simple function body") # (print "parsing simple function body")
(try (try
(do (do
(def lhs (tup-pattern parser)) (def lhs (tup-pattern parser))
(print "parsed lhs") # (print "parsed lhs")
(def guard (when (check parser :if) (def guard (when (check parser :if)
(advance parser) (advance parser)
(simple parser))) (simple parser)))
(print "parsed guard") # (print "parsed guard")
(expect parser :arrow) (advance parser) (expect parser :arrow) (advance parser)
(print "parsed arrow") # (print "parsed arrow")
(accept-many parser :newline) (accept-many parser :newline)
(def rhs (nonbinding parser)) (def rhs (nonbinding parser))
(print "parsed rhs") # (print "parsed rhs")
{:clauses [[lhs guard rhs]]} {:clauses [[lhs guard rhs]]}
) )
([err] err) ([err] err)
@ -753,7 +753,7 @@
) )
(defn- fn-clauses [parser] (defn- fn-clauses [parser]
(print "parsing fn clauses") # (print "parsing fn clauses")
(def origin (current parser)) (def origin (current parser))
(expect parser :lbrace) (advance parser) (expect parser :lbrace) (advance parser)
(accept-many parser ;terminators) (accept-many parser ;terminators)
@ -779,15 +779,15 @@
(if (= :lparen (-> parser peek type)) (break (lambda parser))) (if (= :lparen (-> parser peek type)) (break (lambda parser)))
(try (try
(do (do
(print "parsing named function") # (print "parsing named function")
(def origin (current parser)) (def origin (current parser))
(expect parser :fn) (advance parser) (expect parser :fn) (advance parser)
(print "consumed `fn`") # (print "consumed `fn`")
(print "next token: ") # (print "next token: ")
(pp (current parser)) # (pp (current parser))
(def name (-> parser word-only (get :data))) (def name (-> parser word-only (get :data)))
(print "function name: ") # (print "function name: ")
(pp name) # (pp name)
(def {:clauses data :doc doc} (case (-> parser current type) (def {:clauses data :doc doc} (case (-> parser current type)
:lbrace (fn-clauses parser) :lbrace (fn-clauses parser)
:lparen (fn-simple parser) :lparen (fn-simple parser)
@ -819,8 +819,8 @@
(expect parser :do) (advance parser) (expect parser :do) (advance parser)
(def data @[]) (def data @[])
(array/push data (capture simple parser)) (array/push data (capture simple parser))
(print "added first expression. current token:") # (print "added first expression. current token:")
(pp (current parser)) # (pp (current parser))
(while (check parser :pipeline) (while (check parser :pipeline)
(advance parser) (advance parser)
(accept-many parser :newline) (accept-many parser :newline)
@ -1114,37 +1114,12 @@
(set (parser :ast) ast) (set (parser :ast) ast)
parser) parser)
(defn- indent-by [n] # (do
(def indentation @"") (comment
(repeat n (buffer/push indentation ".."))
indentation)
(defn- pp-ast [ast &opt indent]
(default indent 0)
(def {:type t :name n :data d :msg m} ast)
(string (indent-by indent) t ": " n m
(if (indexed? d)
(string "\n" (string/join (map (fn [a] (pp-ast a (inc indent))) d)))
d
)
"\n"
)
)
(do
# (comment
(def source `pkg Foo {} (def source `pkg Foo {}
`) `)
(def scanned (s/scan source)) (def scanned (s/scan source))
(print "\n***NEW PARSE***\n") # (print "\n***NEW PARSE***\n")
(def a-parser (new-parser scanned)) (def a-parser (new-parser scanned))
(def parsed (pkg a-parser)) (def parsed (pkg a-parser))
) )
# FIXME:
# TODO:
# DECIDE:
# - when to use a flat try/catch format, and when to use capture/expect-ret to get values instead of errors

10
janet/scanner.janet
View File

@ -341,9 +341,9 @@
(recur (-> scanner (scan-token) (next-token))))) (recur (-> scanner (scan-token) (next-token)))))
(recur (new-scanner source input))) (recur (new-scanner source input)))
(def source ` # (def source `
a :b "c" # a :b "c"
& thing # & thing
`) # `)
(pp ((scan source) :tokens)) # (pp ((scan source) :tokens))

124
janet/validate.janet
View File

@ -27,7 +27,7 @@ Deferred until a later iteration of Ludus:
(def- package-registry @{}) (def- package-registry @{})
(try (os/cd "janet") ([_] nil)) # (try (os/cd "janet") ([_] nil))
(import ./scanner :as s) (import ./scanner :as s)
(import ./parser :as p) (import ./parser :as p)
@ -159,7 +159,7 @@ Deferred until a later iteration of Ludus:
{:node ast :msg (string "name is already bound on line " {:node ast :msg (string "name is already bound on line "
line " of " input)})) line " of " input)}))
(set (ctx name) ast) (set (ctx name) ast)
(pp ctx) # (pp ctx)
validator) validator)
(def types [ (def types [
@ -219,10 +219,10 @@ Deferred until a later iteration of Ludus:
(pattern validator)) (pattern validator))
(defn- pattern* [validator] (defn- pattern* [validator]
(print "PATTERN*") # (print "PATTERN*")
(def ast (validator :ast)) (def ast (validator :ast))
(def type (ast :type)) (def type (ast :type))
(print "validating pattern " type) # (print "validating pattern " type)
(cond (cond
(has-value? terminals type) validator (has-value? terminals type) validator
(case type (case type
@ -246,7 +246,7 @@ Deferred until a later iteration of Ludus:
(defn- guard [validator]) (defn- guard [validator])
(defn- match-clauses [validator clauses] (defn- match-clauses [validator clauses]
(print "validating clauses in match-clauses") # (print "validating clauses in match-clauses")
(each clause clauses (each clause clauses
(def parent (validator :ctx)) (def parent (validator :ctx))
(def ctx @{:^parent parent}) (def ctx @{:^parent parent})
@ -254,8 +254,8 @@ Deferred until a later iteration of Ludus:
(def [lhs guard rhs] clause) (def [lhs guard rhs] clause)
(set (validator :ast) lhs) (set (validator :ast) lhs)
(pattern validator) (pattern validator)
(pp (validator :ctx)) # (pp (validator :ctx))
(pp (validator :ctx)) # (pp (validator :ctx))
(when guard (when guard
(set (validator :ast) guard) (set (validator :ast) guard)
(validate validator)) (validate validator))
@ -264,14 +264,14 @@ Deferred until a later iteration of Ludus:
(set (validator :ctx) parent))) (set (validator :ctx) parent)))
(defn- matchh [validator] (defn- matchh [validator]
(print "validating in matchh") # (print "validating in matchh")
(def ast (validator :ast)) (def ast (validator :ast))
(def [to-match clauses] (ast :data)) (def [to-match clauses] (ast :data))
(print "validating expression:") # (print "validating expression:")
(pp to-match) # (pp to-match)
(set (validator :ast) to-match) (set (validator :ast) to-match)
(validate validator) (validate validator)
(print "validating clauses") # (print "validating clauses")
(match-clauses validator clauses) (match-clauses validator clauses)
validator) validator)
@ -280,8 +280,8 @@ Deferred until a later iteration of Ludus:
(def declared (get status :declared @{})) (def declared (get status :declared @{}))
(set (declared fnn) true) (set (declared fnn) true)
(set (status :declared) declared) (set (status :declared) declared)
(print "declared function " (fnn :name)) # (print "declared function " (fnn :name))
(pp declared) # (pp declared)
validator) validator)
(defn- define [validator fnn] (defn- define [validator fnn]
@ -289,14 +289,14 @@ Deferred until a later iteration of Ludus:
(def declared (get status :declared @{})) (def declared (get status :declared @{}))
(set (declared fnn) nil) (set (declared fnn) nil)
(set (status :declared) declared) (set (status :declared) declared)
(print "defined function " (fnn :name)) # (print "defined function " (fnn :name))
(pp declared) # (pp declared)
validator) validator)
(defn- fnn [validator] (defn- fnn [validator]
(def ast (validator :ast)) (def ast (validator :ast))
(def name (ast :name)) (def name (ast :name))
(print "function name: " name) # (print "function name: " name)
(def status (validator :status)) (def status (validator :status))
(def tail? (status :tail)) (def tail? (status :tail))
(set (status :tail) true) (set (status :tail) true)
@ -318,17 +318,17 @@ Deferred until a later iteration of Ludus:
(def rest-arities @{}) (def rest-arities @{})
(def arities @{:rest rest-arities}) (def arities @{:rest rest-arities})
(each clause data (each clause data
(print "CLAUSE:") # (print "CLAUSE:")
(pp clause) # (pp clause)
(def patt (first clause)) (def patt (first clause))
(def params (patt :data)) (def params (patt :data))
(def arity (length params)) (def arity (length params))
(print "checking clause with arity " arity) # (print "checking clause with arity " arity)
(def rest-param? (and (> arity 0) (= :splat ((last params) :type)))) (def rest-param? (and (> arity 0) (= :splat ((last params) :type))))
(if rest-param? (if rest-param?
(set (rest-arities arity) true) (set (rest-arities arity) true)
(set (arities arity) true))) (set (arities arity) true)))
(pp arities) # (pp arities)
(set (ast :arities) arities) (set (ast :arities) arities)
validator) validator)
@ -359,7 +359,7 @@ Deferred until a later iteration of Ludus:
# * [ ] ensure properties are on pkgs (if *only* pkgs from root) # * [ ] ensure properties are on pkgs (if *only* pkgs from root)
(defn- pkg-root [validator] (defn- pkg-root [validator]
(print "validating pkg-root access") # (print "validating pkg-root access")
(def ast (validator :ast)) (def ast (validator :ast))
(def ctx (validator :ctx)) (def ctx (validator :ctx))
(def terms (ast :data)) (def terms (ast :data))
@ -378,7 +378,7 @@ Deferred until a later iteration of Ludus:
{:node member :msg "cannot call a pkg"} {:node member :msg "cannot call a pkg"}
(break validator))))) (break validator)))))
(when (not accessed) (when (not accessed)
(print "no member " (member :data) " on " pkg-name) # (print "no member " (member :data) " on " pkg-name)
(array/push (validator :errors) (array/push (validator :errors)
{:node member :msg "invalid pkg access"}) {:node member :msg "invalid pkg access"})
(break validator)) (break validator))
@ -395,38 +395,38 @@ Deferred until a later iteration of Ludus:
# (set (args :tail-call) true)) # (set (args :tail-call) true))
(defn- check-arity [validator] (defn- check-arity [validator]
(print "CHECKING ARITY") # (print "CHECKING ARITY")
(def ast (validator :ast)) (def ast (validator :ast))
# (when (ast :partial) (break validator)) # (when (ast :partial) (break validator))
(def ctx (validator :ctx)) (def ctx (validator :ctx))
(def data (ast :data)) (def data (ast :data))
(def fn-word (first data)) (def fn-word (first data))
(pp fn-word) # (pp fn-word)
(def the-fn (resolve-name ctx (fn-word :data))) (def the-fn (resolve-name ctx (fn-word :data)))
(print "the called function: " the-fn) # (print "the called function: " the-fn)
(pp the-fn) # (pp the-fn)
(when (not the-fn) (break validator)) (when (not the-fn) (break validator))
(print "the function is not nil") # (print "the function is not nil")
(print "the function type is " (type the-fn)) # (print "the function type is " (type the-fn))
(when (= :function (type the-fn)) (break validator)) (when (= :function (type the-fn)) (break validator))
(when (= :cfunction (type the-fn)) (break validator)) (when (= :cfunction (type the-fn)) (break validator))
(print "the function is not a janet fn") # (print "the function is not a janet fn")
(print "fn type: " (the-fn :type)) # (print "fn type: " (the-fn :type))
(when (not= :fn (the-fn :type)) (break validator)) (when (not= :fn (the-fn :type)) (break validator))
(print "fn name: " (the-fn :name)) # (print "fn name: " (the-fn :name))
(def arities (the-fn :arities)) (def arities (the-fn :arities))
# when there aren't arities yet, break, since that means we're making a recursive function call # when there aren't arities yet, break, since that means we're making a recursive function call
# TODO: enahnce this so that we can determine arities *before* all function bodies; this ensures arity-checking for self-recursive calls # TODO: enahnce this so that we can determine arities *before* all function bodies; this ensures arity-checking for self-recursive calls
(when (not arities) (break validator)) (when (not arities) (break validator))
(print "arities: ") # (print "arities: ")
(pp arities) # (pp arities)
(def args (get data 1)) (def args (get data 1))
(def num-args (length (args :data))) (def num-args (length (args :data)))
(print "called with #args " num-args) # (print "called with #args " num-args)
(pp (get (validator :ctx) "bar")) # (pp (get (validator :ctx) "bar"))
(when (has-key? arities num-args) (break validator)) (when (has-key? arities num-args) (break validator))
(print "arities: ") # (print "arities: ")
(pp arities) # (pp arities)
(when (not arities) (break validator)) (when (not arities) (break validator))
(def rest-arities (keys (arities :rest))) (def rest-arities (keys (arities :rest)))
(when (empty? rest-arities) (when (empty? rest-arities)
@ -464,9 +464,9 @@ Deferred until a later iteration of Ludus:
(set (validator :ast) node) (set (validator :ast) node)
(validate validator)) (validate validator))
(set (validator :ast) ast) (set (validator :ast) ast)
(print "ftype " ftype) # (print "ftype " ftype)
(print "stype " stype) # (print "stype " stype)
(print "ltype " ltype) # (print "ltype " ltype)
(when (= ftype :pkg-name) (pkg-root validator)) (when (= ftype :pkg-name) (pkg-root validator))
(when (= ftype :keyword) (kw-root validator)) (when (= ftype :keyword) (kw-root validator))
# (when (= ltype :args) (tail-call validator)) # (when (= ltype :args) (tail-call validator))
@ -544,9 +544,9 @@ Deferred until a later iteration of Ludus:
(set (status :pkg-access?) true)) (set (status :pkg-access?) true))
(def data (ast :data)) (def data (ast :data))
(def [key value] (ast :data)) (def [key value] (ast :data))
(print "PKG ENTRY***") # (print "PKG ENTRY***")
(pp key) # (pp key)
(pp value) # (pp value)
(set (validator :ast) key) (set (validator :ast) key)
(validate validator) (validate validator)
(set (validator :ast) value) (set (validator :ast) value)
@ -554,13 +554,13 @@ Deferred until a later iteration of Ludus:
(def entry (if (= :pkg-name (value :type)) (def entry (if (= :pkg-name (value :type))
(resolve-name (validator :ctx) (string (value :data))) (resolve-name (validator :ctx) (string (value :data)))
value)) value))
(print "entry at " (key :data)) # (print "entry at " (key :data))
(pp entry) # (pp entry)
(set (status :pkg-access?) nil) (set (status :pkg-access?) nil)
(def kw (key :data)) (def kw (key :data))
(pp kw) # (pp kw)
(set (pkg kw) entry) (set (pkg kw) entry)
(pp pkg) # (pp pkg)
validator) validator)
(defn- pkg [validator] (defn- pkg [validator]
@ -572,8 +572,8 @@ Deferred until a later iteration of Ludus:
(set (validator :ast) node) (set (validator :ast) node)
(pkg-entry validator pkg)) (pkg-entry validator pkg))
(set (ast :pkg) pkg) (set (ast :pkg) pkg)
(print "THE PACKAGE") # (print "THE PACKAGE")
(pp pkg) # (pp pkg)
(def ctx (validator :ctx)) (def ctx (validator :ctx))
(set (ctx name) ast) (set (ctx name) ast)
validator) validator)
@ -597,23 +597,23 @@ Deferred until a later iteration of Ludus:
(def status (validator :status)) (def status (validator :status))
(def data (ast :data)) (def data (ast :data))
(def input (first data)) (def input (first data))
(print "LOOP INPUT") # (print "LOOP INPUT")
(pp input) # (pp input)
(def clauses (get data 1)) (def clauses (get data 1))
(def input-arity (length (input :data))) (def input-arity (length (input :data)))
(set (ast :arity) input-arity) (set (ast :arity) input-arity)
(print "input arity to loop " input-arity) # (print "input arity to loop " input-arity)
(set (validator :ast) input) (set (validator :ast) input)
(validate validator) (validate validator)
# harmonize arities # harmonize arities
(def rest-arities @{}) (def rest-arities @{})
(each clause clauses (each clause clauses
(print "CLAUSE:") # (print "CLAUSE:")
(pp clause) # (pp clause)
(def patt (first clause)) (def patt (first clause))
(def params (patt :data)) (def params (patt :data))
(def clause-arity (length params)) (def clause-arity (length params))
(print "checking clause with arity " clause-arity) # (print "checking clause with arity " clause-arity)
(def rest-param? (= :splat (get (last params) :type))) (def rest-param? (= :splat (get (last params) :type)))
(when (and (when (and
(not rest-param?) (not= clause-arity input-arity)) (not rest-param?) (not= clause-arity input-arity))
@ -621,7 +621,7 @@ Deferred until a later iteration of Ludus:
{:node patt :msg "arity mismatch"})) {:node patt :msg "arity mismatch"}))
(when rest-param? (when rest-param?
(set (rest-arities clause-arity) patt))) (set (rest-arities clause-arity) patt)))
(pp rest-arities) # (pp rest-arities)
(loop [[arity patt] :pairs rest-arities] (loop [[arity patt] :pairs rest-arities]
(when (< input-arity arity) (when (< input-arity arity)
(array/push (validator :errors) (array/push (validator :errors)
@ -645,8 +645,8 @@ Deferred until a later iteration of Ludus:
(break validator)) (break validator))
(def called-with (get-in ast [:data :data])) (def called-with (get-in ast [:data :data]))
(def recur-arity (length called-with)) (def recur-arity (length called-with))
(print "loop arity " loop-arity) # (print "loop arity " loop-arity)
(print "recur arity" recur-arity) # (print "recur arity" recur-arity)
(when (not= recur-arity loop-arity) (when (not= recur-arity loop-arity)
(array/push (validator :errors) (array/push (validator :errors)
{:node ast :msg "recur must have the same number of args as its loop"})) {:node ast :msg "recur must have the same number of args as its loop"}))
@ -687,17 +687,17 @@ Deferred until a later iteration of Ludus:
validator) validator)
(defn- pkg-kw [validator] (defn- pkg-kw [validator]
(print "validating pkg-kw") # (print "validating pkg-kw")
(def ast (validator :ast)) (def ast (validator :ast))
(def pkg-access? (get-in validator [:status :pkg-access?])) (def pkg-access? (get-in validator [:status :pkg-access?]))
(print "pkg-access? " pkg-access?) # (print "pkg-access? " pkg-access?)
(when (not pkg-access?) (when (not pkg-access?)
(array/push (validator :errors) (array/push (validator :errors)
{:node ast :msg "cannot use pkg-kw here"})) {:node ast :msg "cannot use pkg-kw here"}))
validator) validator)
(defn- pkg-pair [validator] (defn- pkg-pair [validator]
(print "validating pkg-pair") # (print "validating pkg-pair")
(def ast (validator :ast)) (def ast (validator :ast))
(def status (validator :status)) (def status (validator :status))
(def [_ pkg] (ast :data)) (def [_ pkg] (ast :data))
@ -715,7 +715,7 @@ Deferred until a later iteration of Ludus:
(defn- validate* [validator] (defn- validate* [validator]
(def ast (validator :ast)) (def ast (validator :ast))
(def type (ast :type)) (def type (ast :type))
(print "validating node " type) # (print "validating node " type)
(cond (cond
(has-value? terminals type) validator (has-value? terminals type) validator
(has-value? simple-colls type) (simple-coll validator) (has-value? simple-colls type) (simple-coll validator)