src/expand.clj

@@ -4,8 +4,11 @@
             [spec-dict.main :refer [dict]]
             [clojure.set :as set]))
 
-(defmacro todo []
-  `(throw (ex-info "todo" {})))
+(defmacro todo
+  ([] `(throw (ex-info "todo" {})))
+  ([fmt & xs]
+   `(throw (ex-info (format (str "todo: " ~fmt) ~@xs)
+                    {}))))
 
 (def primitives
   #{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if 'define
@@ -55,14 +58,18 @@
          (s/cat :pattern ::pattern
                 :template ::template)))
 
+;; cf. `::prim-syntax-rules`
 (s/def ::transformer
-  (dict {:rules (s/coll-of ::rule :kind sequential?)}))
+  (dict {:rules (s/coll-of ::rule :kind sequential?)}
+        ^:opt {:keywords (s/coll-of symbol?)}))
 
 (s/def ::denotation
   #(match %
      [:var] true
      [:primitive p] (primitives p)
-     [:macro trans] (s/valid? ::transformer trans)))
+     [:macro trans]
+     ;; 나쁜
+     (contains? trans :rules)))
 
 (s/def ::environment
   (s/map-of ::binding ::denotation))
@@ -95,6 +102,7 @@
 
 (s/def ::prim-let-syntax ::prim-let)
 
+;; cf. `::transformer`
 (s/def ::prim-syntax-rules
   (s/cat :keyword symbol?
          :keywords (s/coll-of symbol?)
@@ -143,10 +151,10 @@
 
     [[:list {:leading leading}]
      (_ :guard seq?)]
-    (and (= (count datum)
-            (count leading))
-         (->> (map #(unify* %1 %2) leading datum)
-              (apply merge-unify)))
+    (when (= (count datum)
+             (count leading))
+      (->> (map #(unify* %1 %2) leading datum)
+           (apply merge-unify)))
 
     ;; no match
     :else nil))
@@ -172,30 +180,46 @@
       (throw (ex-info "나쁜 점점점" {})))
     :else unif))
 
-(defn- transcribe* [ellipsis-depth unification template]
-  (match template
-    [:var x]
-    (match (get unification x)
-      ([:ellipsis _] :as p)
-      (strip-ellipsis p ellipsis-depth)
+(defn- transcribe*
+  ([unification template]
+   (transcribe* 0 unification template))
+  ([ellipsis-depth unification template]
+   (match template
+     [:lit l] l
 
-      (_ :guard nil?)
-      #_(throw (ex-info "unbound" {:symbol x}))
-      x ;; unhygenic but it's demo }:)
+     [:var x]
+     (match (get unification x)
+       ([:ellipsis _] :as p)
+       (strip-ellipsis p ellipsis-depth)
 
-      p p)
+       (_ :guard nil?)
+       #_(throw (ex-info "unbound" {:symbol x}))
+       x ;; unhygenic but it's demo }:)
 
-    [:list ts]
-    (do #_ #dbg (+ 0 0)
-        (->> (for [t ts]
-               (match t
-                 [:ellipsis t*] (transcribe* (inc ellipsis-depth) unification t*)
-                 :else [(transcribe* ellipsis-depth unification t)]))
-             (apply concat)))))
+       p p)
+
+     [:list ts]
+     (do #_ #dbg (+ 0 0)
+         (->> (for [t ts]
+                (match t
+                  [:ellipsis t*] (transcribe* (inc ellipsis-depth) unification t*)
+                  :else [(transcribe* ellipsis-depth unification t)]))
+              (apply concat))))))
 
 (defn transcribe [unification template]
   (transcribe* 0 unification (s/conform ::template template)))
 
+(comment
+  (transcribe-transformer scheme-and '(and 1)))
+
+(defn transcribe-transformer [trans datum]
+  (some (fn [{:keys [pattern template]}]
+          (when-some [unification (unify* pattern datum)]
+            (let [r (transcribe* unification template)]
+              (assert r)
+              r)))
+        (:rules trans)))
+
 
 
 (defn symtable-for-env [env]
@@ -203,9 +227,21 @@
         (for [[[_ x] _] env]
           [x {#{} [:global x]}])))
 
+(defmacro meta-syntax-rules [kws & body]
+  `(s/conform ::prim-syntax-rules
+              (list 'syntax-rules '~kws
+                    ~@(map (fn [x] `(quote ~x)) body))))
+
 (def scheme-base-env
   (merge
-   {[:global 'λ] [:primitive 'lambda]}
+   {[:global 'λ] [:primitive 'lambda]
+    [:global 'and]
+    [:macro
+     (meta-syntax-rules ()
+       ((_) false)
+       ((_ a) a)
+       ((_ a b ...)
+        (if a (and b ...) a)))]}
    (into {} (for [p primitives]
               [[:global p] [:primitive p]]))
    (into {} (for [b '(+ - * / car cdr cons)]
@@ -281,7 +317,8 @@
                     (for [[x rhs] bindings]
                       (bind-lexical
                        [x scopes*]
-                       [:macro (expand rhs env symtable-ref scopes)]
+                       [:macro (->> (expand rhs env symtable-ref scopes)
+                                    (s/conform ::transformer))]
                        symtable-ref)))]
     (concat (list 'let-syntax bindings)
             (for [e body]
@@ -309,6 +346,8 @@
      (match (lookup [f scopes] env @symtable-ref)
        [:primitive prim] (expand-primitive
                           datum prim env symtable-ref scopes)
-       [:macro trans] (todo)
+       [:macro trans] (todo "trans %s" (->> trans
+                                            (s/conform ::prim-syntax-rules)
+                                            pr-str))
        _ (cons (expand f env symtable-ref scopes)
                (map #(expand % env symtable-ref scopes) xs))))))