pattern spec

src/expand.clj

@@ -4,6 +4,9 @@
             [spec-dict.main :refer [dict]]
             [clojure.set :as set]))
 
+(defmacro todo []
+  `(throw (ex-info "todo" {})))
+
 (def primitives
   #{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if 'define
     'define-syntax})
@@ -13,10 +16,43 @@
      [:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
      [:global sym] (symbol? sym)))
 
+(defn- parse-pattern-list [pat]
+  (loop [xs pat
+         acc {:type :list :leading []}]
+    (match xs
+      ([x '... & ys] :seq) (-> acc
+                               (assoc :ellipsis x :trailing (seq ys))
+                               (update :leading seq))
+      ([] :seq) (update acc :leading seq)
+      ([x & ys] :seq) (recur ys (update acc :leading #(conj % x))))))
+
 (s/def ::pattern
-  (s/or :var symbol?
-        :list (s/coll-of ::pattern :kind sequential?)
-        :lit ::literal))
+  (s/or :var (s/and symbol?
+                    #(not= '... %))
+        :lit ::literal
+        :list (s/and seq?
+                     (s/cat :leading (s/* ::pattern)
+                            :rest (s/? (s/cat :ellipsis #{'...}
+                                              :trailing (s/* ::pattern))))
+                     (s/conformer
+                      (fn [pat]
+                        (if-some [{:keys [ellipsis trailing]} (:rest pat)]
+                          (let [{:keys [leading]} pat]
+                            (if-some [variadic (last leading)]
+                              {:leading (vec (butlast leading))
+                               :ellipsis variadic
+                               :trailing trailing}
+                              ::s/invalid))
+                          pat)))))
+  #_(s/conformer
+   (fn go [pat]
+     (cond (seq? pat)
+           (-> (parse-pattern-list pat)
+               (update :leading #(map go %))
+               (update :ellipsis #(some-> % go))
+               (update :trailing #(map go %)))
+           (symbol? pat) pat
+           :else ::s/invalid))))
 
 (s/def ::literal (some-fn string? boolean? number? char?))
 
@@ -92,6 +128,10 @@
 
 
 
+
+
+
+
 (defn symtable-for-env [env]
   (into {}
         (for [[[_ x] _] env]
@@ -167,6 +207,25 @@
             (for [e body]
               (expand e env* symtable-ref scopes*)))))
 
+(defmethod expand-primitive 'let-syntax
+  [datum _ env symtable-ref scopes]
+  (let [{:keys [bindings body]} (s/conform ::prim-let-syntax datum)
+        scopes* (conj scopes (new-scope))
+        env* (apply merge env
+                    (for [[x rhs] bindings]
+                      (bind-lexical
+                       [x scopes*]
+                       [:macro (expand rhs env symtable-ref scopes)]
+                       symtable-ref)))]
+    (concat (list 'let-syntax bindings)
+            (for [e body]
+              (expand e env* symtable-ref scopes*)))))
+
+(defmethod expand-primitive 'syntax-rules
+  [datum _ env symtable-ref scopes]
+  (assert (s/valid? ::prim-syntax-rules datum))
+  datum)
+
 (defn expand
   ([datum]
    (expand
@@ -184,5 +243,6 @@
      (match (lookup [f scopes] env @symtable-ref)
        [:primitive prim] (expand-primitive
                           datum prim env symtable-ref scopes)
+       [:macro trans] (todo)
        _ (cons (expand f env symtable-ref scopes)
                (map #(expand % env symtable-ref scopes) xs))))))

test/expand_test.clj

@@ -18,11 +18,11 @@
            (sut/nearest ['x #{0 1 2}]
                         [#{0} #{0 1} #{0 3}]))))
 
-(t/deftest parse-pattern-test
+(t/deftest pattern-spec
   (t/testing "list"
     (t/are [l e t x] (= [l e t]
                         ((juxt :leading :ellipsis :trailing)
-                         (sut/parse-pattern x)))
+                         (s/conform ::pattern x)))
       nil nil nil '()
       '(a) nil nil '(a)
       '(a b) nil nil '(a b)