basic transcription

src/expand.clj

@@ -12,7 +12,7 @@
 
 (def primitives
   #{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if 'define
-    'define-syntax})
+    'define-syntax 'begin})
 
 (s/def ::binding
   #(match %
@@ -40,6 +40,11 @@
 
 (s/def ::literal (some-fn string? boolean? number? char?))
 
+(defn literal? [x]
+  (s/valid? ::literal x))
+
+(s/def ::datum any?)
+
 (s/def ::template
   (s/or :var symbol?
         :lit ::literal
@@ -93,13 +98,48 @@
 (s/def ::body
   (s/+ any?))
 
+(s/def ::variable
+  (s/conformer
+   #(match %
+      (x :guard symbol?) [x nil]
+      [x scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)]
+                   (if (or (not (symbol? x)) (s/invalid? r))
+                     ::s/invalid
+                     [x scopes]))
+      :else ::s/invalid)))
+
+(defn variable? [x]
+  (s/valid? ::variable x))
+
+(defn variable-symbol [v]
+  (if (symbol? v)
+    v
+    (first v)))
+
+(defn normalise-variale [v]
+  (let [r (s/conform ::variable v)]
+    (when-not (s/invalid? r)
+      r)))
+
+(defn variable-scopes [v]
+  (match v
+    [_ scopes] scopes
+    :else nil))
+
+(defn offer-scopes
+  "variable v는 안 resolve되면 v와 scopes는 붙음."
+  [v scopes]
+  (if-some [ss (variable-scopes v)]
+    [(variable-symbol v) ss]
+    [(variable-symbol v) scopes]))
+
 (s/def ::prim-lambda
-  (s/cat :keyword symbol?
+  (s/cat :keyword ::variable
          :formals ::formals
          :body ::body))
 
 (s/def ::prim-let
-  (s/cat :keyword symbol?
+  (s/cat :keyword ::variable
          :bindings (s/coll-of #(and (sequential? %)
                                     (= 2 (count %))
                                     (symbol? (first %)))
@@ -110,9 +150,15 @@
 
 ;; cf. `::transformer`
 (s/def ::prim-syntax-rules
-  (s/cat :keyword symbol?
-         :keywords (s/coll-of symbol?)
-         :rules (s/* ::rule)))
+  (s/and seq? (s/cat :keyword ::variable
+                     :keywords (s/coll-of symbol?)
+                     :rules (s/* ::rule))))
+
+(s/def ::prim-if
+  (s/and seq? (s/cat :keyword ::variable
+                     :condition ::datum
+                     :consequent ::datum
+                     :alternative (s/? ::datum))))
 
 
 
@@ -129,13 +175,16 @@
 (def scheme-base-env
   (merge
    {[:global 'λ] [:primitive 'lambda]
-    [:global 'and]
-    [:macro
-     (meta-syntax-rules ()
-       ((_) false)
-       ((_ a) a)
-       ((_ a b ...)
-        (if a (and b ...) a)))]}
+    [:global 'and] [:macro
+                    (meta-syntax-rules ()
+                      ((_) false)
+                      ((_ a) a)
+                      ((_ a b ...)
+                       (if a (and b ...) a)))]
+    [:global 'when] [:macro
+                     (meta-syntax-rules ()
+                       ((_ test body)
+                        (if test body)))]}
    (into {} (for [p primitives]
               [[:global p] [:primitive p]]))
    (into {} (for [b '(+ - * / car cdr cons)]
@@ -155,8 +204,11 @@
                   :when (= sym x)]
               scopes)))
 
-(defn lookup [[sym scopes] env symtable]
-  (let [ss (symtable-scopes symtable sym)]
+(defn lookup [variable env symtable]
+  (tap> [variable env symtable])
+  (let [[sym scopes] (or (normalise-variale variable)
+                         (throw (ex-info "not a var" {:var variable})))
+        ss (symtable-scopes symtable sym)]
     (let [xs (nearest [sym scopes] ss)
           r (compare (count xs) 1)]
       (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
@@ -187,26 +239,20 @@
 (defn make-symtable [[sym scopes] bind]
   {[sym scopes] bind})
 
-(defn bind-lexical* [[sym scopes] denot]
-  (let [bind [:lexical sym (gensym)]]
-    {:symtable (make-symtable [sym scopes] bind)
-     :env {bind denot}}))
-
 
 
-(defn- merge-unify-with
-  ([f g] {})
-  ([f g a] a)
-  ([f g a b] (and a b {:env (merge-with f (:env a) (:env b))
-                       :symtable (merge-with g (:symtable a) (:symtable b))}))
-  ([f g a b & xs] (reduce #(merge-unify-with f g %1 %2) (cons a (cons b xs)))))
-
 (defn- report-conflict [x y]
   (throw (ex-info "너무 정의합니다"
                   {:x x :y y})))
 
+(defn- merge-unify-with
+  ([f] {})
+  ([f a] a)
+  ([f a b] (and a b (merge-with f a b)))
+  ([f a b & xs] (reduce #(merge-unify-with f %1 %2) (cons a (cons b xs)))))
+
 (defn- merge-unify [& xs]
-  (apply merge-unify-with report-conflict report-conflict xs))
+  (apply merge-unify-with report-conflict xs))
 
 (comment
   (let [scopes #{1}
@@ -216,46 +262,73 @@
         (unify 'x '(1 2 3) env symtab scopes)]
     (lookup ['x #{1}] (merge env env*) (merge symtab symtab*)))
   (let [scopes #{1}
-        symtab (symtable-for-env scheme-base-env)
         env scheme-base-env
-        {symtab* :symtable env* :env}
-        (unify '(x ...) '(1 2 3) env symtab scopes)]
-    #_(lookup ['x #{1}] (merge env env*) (merge symtab symtab*))
-    symtab*))
+        symtable-ref (atom (symtable-for-env scheme-base-env))]
+    (-> (unify '(a b c ...) '(1 2 3 4 5 6))
+        (unification->env symtable-ref scopes)))
+  (expand '(and 456 123)))
 
-(defn- unify* [pattern datum env symtable scopes bound]
+(defn- unify* [pattern datum]
   (match [pattern datum]
-    [[:wildcard _] _] {:env {} :symtable {}}
-
-    [[:var x] _]
-    (bind-lexical* [x scopes] [:syntax datum])
-
+    [[:wildcard _] _] {}
+    [[:var x] _] {x datum}
+    
     [[:list {:leading leading
              :trailing nil
              :ellipsis ellipsis}]
      (_ :guard seq?)]
     (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)]
-      #dbg (+ 0 0)
-      (todo))
+      (merge-unify
+       (apply merge-unify (map #(unify* %1 %2)
+                               leading
+                               leading-datum))
+       (some->> ellipsis-datum
+                (map #(some-> (unify* ellipsis %)
+                              (update-vals list)))
+                (apply merge-unify-with concat)
+                (map (fn [[k v]]
+                       [k [:ellipsis v]]))
+                (into {}))))
 
     [[:list {:leading leading}]
      (_ :guard seq?)]
     (when (= (count datum)
              (count leading))
-      (->> (map #(unify* %1 %2 env symtable scopes)
-                leading datum)
-           (apply merge-unify)))))
+      (->> (map #(unify* %1 %2) leading datum)
+           (apply merge-unify)))
 
-(defn unify
-  ([pattern datum]
-   (unify* (s/conform ::pattern pattern) datum
-           scheme-base-env
-           (symtable-for-env scheme-base-env)
-           #{}
-           (atom {})))
-  ([pattern datum env symtable scopes]
-   (unify* (s/conform ::pattern pattern) datum env symtable scopes
-           (atom {}))))
+    ;; no match
+    :else nil))
+
+(defn unify [pattern datum]
+  (unify* (s/conform :expand/pattern pattern) datum))
+
+(defn unification->env [unification symtable-ref scopes]
+  (into {}
+        (doall (for [[k v] unification]
+                 (bind-lexical [k scopes] [:syntax v]
+                               symtable-ref)))))
+
+(defn unify-trans
+  "`unify`로 모든 trans의 패턴은 datum을 맞음. datum으로 맞은 패턴은
+  없으면 nil을 결과할 것입나다.
+
+  걸과의 모습은 [rule unification]입니다. 여기서 rule이 최초 맞은
+  trans의 rule이고, unification이 `unify`의 결과입니다."
+  [trans datum]
+  (some (fn [{:keys [pattern template]
+              :as rule}]
+          (when-some [unif (unify* pattern datum)]
+            [rule unif]))
+        (:rules trans)))
+
+(defn transcribe [template env symtable scopes]
+  (match template
+    [:var x] (match (lookup (offer-scopes x scopes) env symtable)
+               [:syntax syn] syn
+               :else (offer-scopes x scopes))
+    [:lit x] x
+    [:list xs] (map #(transcribe % env symtable scopes) xs)))
 
 
 ;;; expand
@@ -282,7 +355,10 @@
                     (for [[x _] bindings]
                       (bind-lexical [x scopes*]
                                     [:var] symtable-ref)))]
-    (concat (list 'let bindings)
+    (concat (list 'let
+                  (for [[k v] bindings]
+                    [(offer-scopes k scopes*)
+                     v]))
             (for [e body]
               (expand e env* symtable-ref scopes*)))))
 
@@ -306,23 +382,60 @@
     (assert (not (s/invalid? r)))
     r))
 
+(defmethod expand-primitive 'if
+  [datum _ env symtable-ref scopes]
+  (let [{:keys [condition consequent alternative]}
+        (s/conform ::prim-if datum)
+        ex #(expand % env symtable-ref scopes)]
+    (concat (list 'if (ex condition)
+                  (ex consequent))
+            (some-> alternative ex))))
+
+(comment
+  (let [env scheme-base-env
+        [_ trans] (get scheme-base-env [:global 'and])
+        datum '(and 12 34)
+        symtable-ref (atom (symtable-for-env env))
+        scopes #{1}]
+    (expand-macro
+     trans datum
+     env symtable-ref scopes)))
+
+(defn expand-macro [trans datum env symtable-ref scopes]
+  (let [[rule unif]
+        (-> (unify-trans trans datum)
+            (or (throw
+                 (ex-info
+                  "데이텀을 맞은 패턴은 찾을 수 없었습니다"
+                  {:trans trans :datum datum}))))
+        scopes* (conj scopes (new-scope))
+        env* (merge env (unification->env unif symtable-ref scopes*))]
+    (expand (transcribe (:template rule) env* @symtable-ref scopes*)
+            env ;; 아마도 `env*`를 써야 되고 `env`를 안 써야 될까?
+            symtable-ref
+            scopes)))
+
 (defn expand
   ([datum]
    (expand
     datum scheme-base-env (atom (symtable-for-env scheme-base-env)) #{}))
   ([datum env symtable-ref scopes]
+   (tap> datum)
    (match datum
      ;; literals
-     (x :guard (some-fn boolean? number?)) x
-     ;; variables
-     (x :guard symbol?)
-     (do (lookup [x scopes] env @symtable-ref)
-         x)
-     ;;
+     (x :guard literal?) x
+     ;; variables (both resolved and unresolved)
+     (x :guard variable?)
+     (let [x* (offer-scopes x scopes)]
+       (lookup x* env @symtable-ref) ; throw if unbound
+       x*)
+
+     ;; lists
      ([f & xs] :seq)
-     (match (lookup [f scopes] env @symtable-ref)
-       [:primitive prim] (expand-primitive
-                          datum prim env symtable-ref scopes)
-       [:macro trans] (todo "trans %s" (->> (pr-str trans)))
-       _ (cons (expand f env symtable-ref scopes)
-               (map #(expand % env symtable-ref scopes) xs))))))
+     (if (variable? f)
+       (match (lookup (offer-scopes f scopes) env @symtable-ref)
+         [:primitive prim] (expand-primitive
+                            datum prim env symtable-ref scopes)
+         [:macro trans] (expand-macro trans datum env symtable-ref scopes))
+       (cons (expand f env symtable-ref scopes)
+             (map #(expand % env symtable-ref scopes) xs))))))