janet/recursive.janet

@@ -1,15 +1,20 @@
 ### A recursive descent parser for Ludus
 
 ### We still need to scan some things
-#(os/cd "janet") # when in repl to do relative imports
+(os/cd "janet") # when in repl to do relative imports
 (import ./scanner :as s)
 
+### First, some mutual recursion helpers
+(defn unreachable 
+ "A function that errors out if called."
+ [&] (error "reached the unreachable"))
+
 (defmacro declare
  "Forward-declares a function name, so that it can be called in a mutually recursive manner."
  [& names]
   (def bindings @[])
   (loop [name :in names]
-   (def binding ~(var ,name nil))
+   (def binding ~(var ,name unreachable))
    (array/push bindings binding))
   ~(upscope ,;bindings))
 
@@ -17,7 +22,7 @@
  "Defines a function depended on by another function, that has been forward `declare`d."
  [name & forms]
   (if-not (dyn name) (error "recursive functions must be declared before they are defined"))
-  ~(set ,name (defn- ,name ,;forms)))
+  ~(set ,name (defn ,name ,;forms)))
 
 ### Next: a data structure for a parser
 (defn- new-parser 
@@ -134,7 +139,7 @@
 
 # atoms
 (defn- bool [parser]
- (expect parser :true :false)
+ (expect parser :bool)
  (def curr (-> parser current))
  (def ttype (type curr))
  (def value (if (= ttype :true) true false))
@@ -189,6 +194,9 @@
    {:type :word :data (first-token :lexeme) :token first-token}
   :else {:type :error :msg "string interpolations/patterns must be single words"}))
 
+(def foo [{:foo :bar}])
+(-> foo first (get :foo))
+
 (defn- is-error? [data]
  (cond
   (buffer? data) false
@@ -352,7 +360,7 @@
   (def term (if (check parser :splat)
    (do
     (advance parser)
-    (def splatted (capture word-only parser))
+    (def splatted (try (word-only parser) ([e] e)))
     {:type :splat :data splatted :token origin}
    )
    (capture nonbinding parser)))
@@ -404,7 +412,7 @@
     (def key (try (kw parser) ([e] e)))
     (def value (capture nonbinding parser))
     {:type :pair :data [key value] :token origin})
-   (try (panic parser (string "expected dict term, got " (type origin))) ([e] e))
+   (try (panic parser (string expect "expected dict term, got " (type origin))) ([e] e))
   ))
   (array/push (ast :data) term)
   (try (separators parser) ([e] (array/push (ast :data) e))))
@@ -491,16 +499,12 @@
   (def origin (current parser))
   (def term (case (type origin)
    :splat {:type :splat :data (when (check (advance parser) :word) (word-only parser)) :token origin}
-   :word (do
-    (def word (capture word-pattern parser))
-    (def name (word :data))
-    (def key {:type :keyword :data (keyword name) :token origin})
-    {:type :pair :data [key word] :token origin})
+   :word (capture word-pattern parser)
    :keyword (do
     (def key (capture kw parser))
     (def value (capture pattern parser))
     {:type :pair :data [key value] :token origin})
-   (try (panic parser (string "expected dict term, got " (type origin))) ([e] e))
+   (try (panic parser (string expect "expected dict term, got " (type origin))) ([e] e))
   ))
   (array/push (ast :data) term)
   (try (separators parser) ([e] (array/push (ast :data) e))))
@@ -739,7 +743,6 @@
   (if (check parser :eof) 
    (error {:type :error :token origin :data data :msg "unclosed brace"}))
   (array/push data (capture fn-clause parser)))
- (advance parser)
  data)
 
 (defn- lambda [parser]
@@ -778,7 +781,6 @@
    (error {:type :error :token origin :data data :msg "unclosed brace"}))
   (array/push data (capture expr parser))
   (terminator parser))
- (advance parser)
  {:type :block :data data :token origin})
 
 ### TODO: decide whether this design works
@@ -941,7 +943,7 @@
   :pkg-name (pkg-name parser)
   :recur (recur parser)
   :panic (panicc parser)
-  (panic parser (string "expected simple expression, got " (type curr)))
+  (panic parser (string expect "expected simple expression, got " (type curr)))
  )
 )
 
@@ -1015,7 +1017,6 @@
   :number (num parser)
   :keyword (kw parser)
   :string (str parser)
-  :interpolated (interpolated parser)
   :lparen (tup parser)
   :lbracket (list parser)
   :startdict (dict parser)
@@ -1059,12 +1060,6 @@
   (capture terminator parser))
  {:type :script :data lines :token origin})
 
-(defn parse [scanned]
-  (def parser (new-parser scanned))
-  (def ast (script parser))
-  (set (parser :ast) ast)
-  parser)
-
 (defn- indent-by [n]
  (def indentation @"")
  (repeat n (buffer/push indentation ".."))
@@ -1086,13 +1081,12 @@
 (do
 #(comment
 (def source `
-"foo {bar} baz"
+panic! foo
 `)
 (def scanned (s/scan source))
-(print "\n***NEW PARSE***\n")
 (def a-parser (new-parser scanned))
-(def parsed (script a-parser))
-
+(print "\n***NEW PARSE***\n")
+(def parsed (toplevel a-parser))
 # (print (pp-ast parsed))
 (pp parsed)
 )

janet/validate.janet

@@ -4,291 +4,17 @@
 
 Tracking here, before I start writing this code, the kinds of validation we're hoping to accomplish:
 
-* [x] splats come at the end of list, tuple, and dict patterns
-* [x] no unbound names
-* [x] no re-bound names
-* [ ] no unbound names with `use` forms
-* [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
-* [ ] recur in tail position in `loop` forms
-* [ ] recur not called outside of `loop` forms
-* [ ] `loop` form arity checking
-* [ ] arity checking of explicit named function calls
-* [ ] flag tail calls
-* [ ] no circular imports DEFERRED
-* [ ] correct imports DEFERRED
+* splats come at the end of list, tuple, and dict patterns
+* no unbound names
+* no re-bound names
+* correct imports
+* no unbound names with `use` forms
+* no circular imports
+* first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
+* recur in tail position in `loop` forms
+* recur not called outside of `loop` forms
+* arity checking where possible
+ - loop forms
+ - try to resolve function name, if you can, check arity of call
 
 )
-
-
-(import ./recursive :as p)
-(import ./scanner :as s)
-
-(defn- new-validator [parser]
- (def ast (parser :ast))
- @{:ast ast
- :errors @[]
- :ctx @{}
- :status @{}}
-)
-
-(var validate nil)
-
-(def terminals [:number :keyword :string :bool :nil])
-
-(def simple-colls [:list :tuple :set])
-
-(defn- simple-coll [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (each node data 
-  (set (validator :ast) node)
-  (validate validator))
- validator)
-
-(defn- iff [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (each node data
-  (set (validator :ast) node)
-  (validate validator))
- validator)
-
-(defn- script [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (def status (validator :status))
- (set (status :toplevel) true)
- (each node data
-  (set (validator :ast) node)
-  (validate validator))
- validator)
-
-(defn- block [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (def status (validator :status))
- (set (status :toplevel) nil)
- (def parent (validator :ctx))
- (def ctx @{:^parent parent})
- (set (validator :ctx) ctx)
- (each node data
-  (set (validator :ast) node)
-  (validate validator))
- (set (validator :ctx) parent)
- validator)
-
-(defn- resolve-name [ctx name]
- (when (nil? ctx) (break nil))
- (def node (get ctx name))
- (if node node (resolve-name (get ctx :^parent) name)))
-
-(defn- word [validator]
- (def ast (validator :ast))
- (def name (ast :data))
- (def ctx (validator :ctx))
- (def resolved (resolve-name ctx name))
- (when (not resolved)
-   (array/push (validator :errors)
-    {:node ast :msg "unbound name"}))
- validator)
-
-
-### patterns
-(var pattern nil)
-
-(defn- lett [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (def status (validator :status))
- (def pattern (first data))
- (def expr (get data 1))
- # evaluate the expression first
- # otherwise lhs names will appear bound
- (set (validator :ast) expr)
- (validate validator)
- (set (validator :ast) pattern)
- (pattern validator)
- validator)
-
-(defn- splattern [validator]
- (def ast (validator :ast))
- (def status (validator :status))
- (when (not (status :last))
-  (array/push (validator :errors) 
-   {:node ast :msg "splats may only come last in collection patterns"}))
- (def data (ast :data))
- (when data
-  (set (validator :ast) data)
-  (pattern validator))
- validator)
-
-(defn- simple-coll-pattern [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (when (empty? data) (break validator))
- (def status (validator :status))
- (for i 0 (-> data length dec)
-  (set (validator :ast) (get data i))
-  (pattern validator))
- (set (status :last) true)
- (set (validator :ast) (last data))
- (pattern validator)
- (set (status :last) nil)
- validator)
-
-### XXX: to do
-(defn- dict-pattern [validator])
-
-(defn- word-pattern [validator]
- (def ast (validator :ast))
- (def name (ast :data))
- (def ctx (validator :ctx))
- (when (has-key? ctx name)
-  (def {:line line :input input} (get-in ctx [name :token]))
-  (array/push (validator :errors)
-   {:node ast :msg (string "name is already bound on line "
-    line " of " input)}))
- (set (ctx name) ast)
- validator)
-
-(defn- pattern* [validator]
- (def ast (validator :ast))
- (def type (ast :type))
- (print "validating pattern " type)
- (cond
-  (has-value? terminals type) validator
-  (case type
-   :word (word-pattern validator)
-   :placeholder validator
-   :ignored validator
-   :word (word-pattern validator)
-   :list (simple-coll-pattern validator)
-   :tuple (simple-coll-pattern validator)
-   :splat (splattern validator))))
-
-(defn- match-clauses [validator clauses]
- (each clause clauses
-  (def parent (validator :ctx))
-  (def ctx @{:^parent parent})
-  (set (validator :ctx) ctx)
-  (def [lhs guard rhs] clause)
-  (set (validator :ast) lhs)
-  (pattern validator)
-  (pp (validator :ctx))
-  (pp (validator :ctx))
-  (when guard
-   (set (validator :ast) guard)
-   (validate validator))
-  (set (validator :ast) rhs)
-  (validate validator)
-  (set (validator :ctx) parent)))
-
-(defn- matchh [validator]
- (def ast (validator :ast))
- (match-clauses validator (ast :data))
- validator)
-
-(defn- fnn [validator]
- (def ast (validator :ast))
- (def name (ast :name))
- (when name 
-  (def ctx (validator :ctx))
-  (def resolved (resolve-name ctx name))
-  (when resolved
-   (def {:line line :input input} (get-in ctx [name :token]))
-   (array/push (validator :errors)
-    {:node ast :msg (string "name is already bound on line " line " of " input)}))
-  (set (ctx name) ast))
- (match-clauses validator (ast :data))
- validator)
-
-(defn- ref [validator]
- (def ast (validator :ast))
- (def ctx (validator :ctx))
- (def expr (ast :data))
- (set (validator :ast) expr)
- (validate validator)
- (def name (ast :name))
- (def resolved (resolve-name ctx name))
- (when resolved
-  (def {:line line :input input} (get-in ctx [name :token]))
-  (array/push (validator :errors)
-   {:node ast :msg (string "name is already bound on line " line " of " input)}))
- (set (ctx name) ast)
- validator)
-
-(defn- interpolated [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (each node data
-  (when (not (buffer? node))
-   (set (validator :ast) node)
-   (validate validator))))
-
-### TODO:
-# * [ ] arity checking if first term is name that resolves to a function and args aren't partial
-# * [ ] ensure properties are on pkgs (prev term in synth is a pkg)
-# * [ ] flag tail calls (where last term is not-partial args)
-(defn- synthetic [validator]
- (def ast (validator :ast))
- (def data (ast :data))
- (each node data
-  (set (validator :ast) node)
-  (validate validator)))
-
-### XXX: todos from parser
-(defn- dict [validator])
-
-(defn- whenn [validator])
-
-(defn- withh [validator])
-
-(defn- doo [validator])
-
-(defn- usee [validator])
-
-(defn- pkg [validator])
-
-(defn- ns [validator])
-
-(defn- loop [validator])
-
-(defn- recur [validator])
-
-(defn- repeat [validator])
-
-(defn- panic [validator])
-
-(defn- validate* [validator]
- (def ast (validator :ast))
- (def type (ast :type))
- (print "validating node " type)
- (cond
-  (has-value? terminals type) true
-  (has-value? simple-colls type) (simple-coll validator)
-  (case type
-   :if (iff validator) 
-   :let (lett validator)
-   :script (script validator)
-   :block (block validator)
-   :word (word validator)
-   :fn (fnn validator)
-   :match (matchh validator)
-   :interpolated (interpolated validator)
-   :synthetic (synthetic validator)
-   (error (string "unknown node type " type)))))
-
-(set validate validate*)
-(set pattern pattern*)
-
-(do
-#(comment
-(def source `
-"foo {bar} baz"
-`)
-(def scanned (s/scan source))
-(def parsed (p/parse scanned))
-(def validator (new-validator parsed))
-(pp validator)
-(validate validator)
-)