diff --git a/src/expand.clj b/src/expand.clj index 2f372d6..1271909 100644 --- a/src/expand.clj +++ b/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)))))) diff --git a/test/expand_test.clj b/test/expand_test.clj index 0dbdd6f..4889d81 100644 --- a/test/expand_test.clj +++ b/test/expand_test.clj @@ -114,7 +114,11 @@ '((b ...) ...) '((1 2) (3 4)) - {} '_ 123)) + {} '_ 123) + (t/testing "non-matches" + (t/are [pattern datum] (= nil (sut/unify pattern datum)) + '(a b c) '(1 2) + '(a b c) '(1 2)))) (t/deftest transcribe-test (t/are [result datum pattern template]