594 lines
18 KiB
Clojure
594 lines
18 KiB
Clojure
(ns old
|
|
(:require [clojure.core.match :refer [match]]
|
|
[clojure.pprint :as pprint]
|
|
[clojure.set :as set]
|
|
[clojure.spec.alpha :as s]
|
|
[clojure.walk]
|
|
[spec-dict.main :refer [dict]]))
|
|
|
|
(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
|
|
define-syntax begin})
|
|
|
|
(def builtins
|
|
'#{+ * / - car cdr write display newline cons list})
|
|
|
|
(s/def ::binding
|
|
#(match %
|
|
[:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
|
|
[:global sym] (symbol? sym)))
|
|
|
|
(s/def ::pattern
|
|
(s/or :wildcard #{'_}
|
|
:var (s/and symbol? (complement #{'... '_}))
|
|
: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/def ::literal (some-fn string? boolean? number? char?))
|
|
|
|
(defn literal? [x]
|
|
(s/valid? ::literal x))
|
|
|
|
(s/def ::datum any?)
|
|
|
|
(declare variable?)
|
|
|
|
(s/def ::template
|
|
(s/or :var ::variable
|
|
:lit ::literal
|
|
:list (s/and (s/* ::template-element) sequential?)))
|
|
|
|
(s/def ::template-element
|
|
(s/& (s/cat :template ::template :ellipsis (s/? #{'...}))
|
|
(s/conformer
|
|
(fn [{:keys [ellipsis template]}]
|
|
(if ellipsis
|
|
[:ellipsis template]
|
|
template)))))
|
|
|
|
(s/def ::rule
|
|
(s/and sequential?
|
|
(s/cat :pattern ::pattern
|
|
:template ::template)))
|
|
|
|
;; cf. `::prim-syntax-rules`
|
|
(s/def ::transformer
|
|
(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] (contains? trans :rules)
|
|
[:syntax datum] true))
|
|
|
|
(s/def ::environment
|
|
(s/map-of ::binding ::denotation))
|
|
|
|
(s/def ::scope symbol?)
|
|
|
|
(s/def ::scope-set (s/coll-of ::scope :kind set?))
|
|
|
|
;; this is an inefficient representation. since we often want to
|
|
;; compute the submap of entries with a symbol 'x' but any scope, it
|
|
;; would be best to 'curry' the table, as Symbol → Scopes →
|
|
;; Binding. however, this is a bit more error-prone and cumbersome for
|
|
;; a prototype.
|
|
(s/def ::symtable
|
|
(s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?))
|
|
::binding))
|
|
|
|
(s/def ::formals
|
|
(s/coll-of symbol? :kind sequential?))
|
|
|
|
(s/def ::body
|
|
(s/+ any?))
|
|
|
|
(declare destructure-variable)
|
|
|
|
(defprotocol IVariable
|
|
(variable-symbol [this])
|
|
(variable-scopes [this]))
|
|
|
|
(deftype Variable [symbol scopes]
|
|
Object
|
|
(equals [x y]
|
|
(if-some [[y-symbol y-scopes] (destructure-variable y)]
|
|
(and (.equals symbol y-symbol)
|
|
(.equals scopes y-scopes))
|
|
false))
|
|
IVariable
|
|
(variable-symbol [this] symbol)
|
|
(variable-scopes [this] scopes))
|
|
|
|
(def ^:dynamic *print-variable-scopes* true)
|
|
|
|
;; does not respect `*print-dup*` lol
|
|
(defmethod print-method Variable [this writer]
|
|
(binding [*out* writer]
|
|
(if *print-variable-scopes*
|
|
(pr [(variable-symbol this) (variable-scopes this)])
|
|
(pr (variable-symbol this)))))
|
|
|
|
(defmethod clojure.pprint/simple-dispatch old.Variable [x]
|
|
(clojure.pprint/simple-dispatch
|
|
(if *print-variable-scopes*
|
|
[(variable-symbol x) (variable-scopes x)]
|
|
(variable-symbol x))))
|
|
|
|
(s/def ::variable
|
|
(s/conformer
|
|
(fn [x]
|
|
(match x
|
|
(_ :guard symbol?) (->Variable x nil)
|
|
(_ :guard #(instance? Variable %))
|
|
(if (symbol? (variable-symbol x))
|
|
(let [r (s/conform ::scope-set (variable-scopes x))]
|
|
(if (s/invalid? r)
|
|
::s/invalid
|
|
(->Variable (variable-symbol x) (variable-scopes x))))
|
|
::s/invalid)
|
|
[sym scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)]
|
|
(if (and (symbol? sym) (not (s/invalid? r)))
|
|
(->Variable sym r)
|
|
::s/invalid))
|
|
:else ::s/invalid))))
|
|
|
|
(defn variable? [x]
|
|
(s/valid? ::variable x))
|
|
|
|
(defn normalise-variale [v]
|
|
(let [r (s/conform ::variable v)]
|
|
(when-not (s/invalid? r)
|
|
r)))
|
|
|
|
(defn destructure-variable [v]
|
|
(let [r (s/conform ::variable v)]
|
|
(when-not (s/invalid? r)
|
|
[(variable-symbol r) (variable-scopes r)])))
|
|
|
|
#_
|
|
(defn variable-scopes [v]
|
|
(when-some [[_ scopes] (destructure-variable v)]
|
|
scopes))
|
|
|
|
#_
|
|
(defn variable-symbol [v]
|
|
(when-some [[s _] (destructure-variable v)]
|
|
s))
|
|
|
|
(defn offer-scopes
|
|
"variable v는 안 resolve되면 v와 scopes는 붙음."
|
|
[v scopes]
|
|
(let [[sym existing-scopes] (destructure-variable v)]
|
|
(->Variable sym (or existing-scopes scopes))))
|
|
|
|
(s/def ::prim-lambda
|
|
(s/cat :keyword ::variable
|
|
:formals ::formals
|
|
:body ::body))
|
|
|
|
(s/def ::prim-let
|
|
(s/cat :keyword ::variable
|
|
:bindings (s/coll-of #(and (sequential? %)
|
|
(= 2 (count %))
|
|
(symbol? (first %)))
|
|
:kind sequential?)
|
|
:body ::body))
|
|
|
|
(s/def ::prim-let-syntax ::prim-let)
|
|
|
|
;; cf. `::transformer`
|
|
(s/def ::prim-syntax-rules
|
|
(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))))
|
|
|
|
(s/def ::prim-begin
|
|
(s/and seq? (s/cat :keyword ::variable
|
|
:body (s/+ ::datum))))
|
|
|
|
|
|
|
|
(defn symtable-for-env [env]
|
|
(into (hash-map)
|
|
(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))))
|
|
|
|
(defn define-global [env-ref symtable-ref sym denot]
|
|
(swap! env-ref #(assoc % [:global sym] denot))
|
|
(swap! symtable-ref #(assoc % [sym #{}] [:global sym])))
|
|
|
|
(declare expand)
|
|
|
|
(defn define-macro [env-ref symtable-ref sym trans]
|
|
(let [trans (->> (expand trans @env-ref symtable-ref #{})
|
|
(s/conform ::prim-syntax-rules))]
|
|
(assert (not (s/invalid? trans)))
|
|
(define-global
|
|
env-ref
|
|
symtable-ref
|
|
sym
|
|
[:macro trans])))
|
|
|
|
(defn scheme-base []
|
|
(let [env-ref (atom {})
|
|
symtable-ref (atom {})]
|
|
(define-global env-ref symtable-ref
|
|
'λ [:primitive 'lambda])
|
|
(doseq [p primitives]
|
|
(define-global env-ref symtable-ref
|
|
p [:primitive p]))
|
|
(doseq [b builtins]
|
|
(define-global env-ref symtable-ref
|
|
b [:var]))
|
|
(define-macro env-ref symtable-ref
|
|
'and '(syntax-rules ()
|
|
((_) false)
|
|
((_ a) a)
|
|
((_ a b ...)
|
|
(if a (and b ...) a))))
|
|
(define-macro env-ref symtable-ref
|
|
'when '(syntax-rules ()
|
|
((_ test body)
|
|
(if test body))
|
|
((_ test body ...)
|
|
(if test (begin body)))))
|
|
{:env @env-ref
|
|
:symtable @symtable-ref})
|
|
#_(merge
|
|
{[:global 'λ] [:primitive 'lambda]
|
|
[: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))
|
|
((_ test body ...)
|
|
(if test (begin body))))]}
|
|
(into {} (for [p primitives]
|
|
[[:global p] [:primitive p]]))
|
|
(into {} (for [b builtins]
|
|
[[:global b] [:var]]))))
|
|
|
|
(defn nearest [[sym scopes] ss]
|
|
(when-some [xs (->> ss
|
|
(filter #(set/subset? % scopes))
|
|
(group-by count)
|
|
seq)]
|
|
(second (apply max-key first xs))))
|
|
|
|
(defn- symtable-scopes
|
|
"Gather the set of scope-sets associated with a given symbol."
|
|
[symtable sym]
|
|
(into #{} (for [[[x scopes] _] symtable
|
|
:when (= sym x)]
|
|
scopes)))
|
|
|
|
(defn lookup [variable env symtable]
|
|
(let [[sym scopes] (or (destructure-variable variable)
|
|
(throw (ex-info "not a var" {:var variable})))
|
|
ss (symtable-scopes symtable sym)
|
|
xs (nearest [sym scopes] ss)
|
|
r (compare (count xs) 1)]
|
|
(cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
|
|
(zero? r)
|
|
(or (get env (or (get symtable [sym (first xs)])
|
|
(throw (ex-info "unreachable" {}))))
|
|
(throw (ex-info "unreachable" {})))
|
|
(pos? r) (throw (ex-info "ambiguous sym" {:sym sym})))))
|
|
|
|
(comment
|
|
(let [{:keys [symtable env]} (scheme-base)
|
|
st (atom symtable)]
|
|
{:e (expand '(lambda (x y) x) env st #{})
|
|
:st @st}))
|
|
|
|
(defmulti expand-primitive
|
|
(fn [_datum prim-name _env _symtable-ref _scopes]
|
|
prim-name))
|
|
|
|
(defn new-scope
|
|
([] (gensym "scope__"))
|
|
([prefix] (gensym (str "scope__" prefix))))
|
|
|
|
(defn bind-lexical [[sym scopes] denot symtable-ref]
|
|
(let [bind [:lexical sym (gensym)]]
|
|
(swap! symtable-ref #(assoc % [sym scopes] bind))
|
|
{bind denot}))
|
|
|
|
(defn make-symtable [[sym scopes] bind]
|
|
{[sym scopes] bind})
|
|
|
|
|
|
|
|
(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 xs))
|
|
|
|
(defn- unify* [pattern datum]
|
|
(match [pattern 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)]
|
|
(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) leading datum)
|
|
(apply merge-unify)))
|
|
|
|
;; no match
|
|
:else nil))
|
|
|
|
(defn unify [pattern datum]
|
|
(unify* (s/conform ::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] (let [x* (offer-scopes x scopes)]
|
|
(match (lookup x* env symtable)
|
|
[:syntax [:ellipsis fuckoffmanjustshadowit]] (todo "점점점")
|
|
[:syntax syn] syn
|
|
:else x*))
|
|
[:ellipsis _] (todo "점점점")
|
|
[:lit x] x
|
|
[:list xs]
|
|
(do (tap> xs)
|
|
(map #(transcribe % env symtable scopes) xs))))
|
|
|
|
(defn resolve-template [template scopes]
|
|
(clojure.walk/postwalk
|
|
#(if (variable? %)
|
|
(offer-scopes % scopes)
|
|
%)
|
|
template))
|
|
|
|
|
|
;;; expand
|
|
|
|
(declare expand)
|
|
|
|
(defmethod expand-primitive 'lambda
|
|
[datum _ env symtable-ref scopes]
|
|
(let [{:keys [formals body]} (s/conform ::prim-lambda datum)
|
|
scopes* (conj scopes (new-scope))
|
|
env* (apply merge env
|
|
(for [x formals]
|
|
(bind-lexical [x scopes*]
|
|
[:var] symtable-ref)))]
|
|
(concat (list 'lambda
|
|
(for [x formals]
|
|
(offer-scopes x scopes*)))
|
|
(for [e body]
|
|
(expand e env* symtable-ref scopes*)))))
|
|
|
|
(defmethod expand-primitive 'let
|
|
[datum _ env symtable-ref scopes]
|
|
(let [{:keys [bindings body]} (s/conform ::prim-let datum)
|
|
scopes* (conj scopes (new-scope))
|
|
env* (apply merge env
|
|
(for [[x _] bindings]
|
|
(bind-lexical [x scopes*]
|
|
[:var] symtable-ref)))]
|
|
(concat (list 'let
|
|
(for [[k v] bindings]
|
|
(list (offer-scopes k scopes*) v)))
|
|
(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]
|
|
(let [trans (->> (expand rhs env symtable-ref scopes)
|
|
(s/conform ::prim-syntax-rules))]
|
|
(assert (not (s/invalid? trans)))
|
|
(bind-lexical
|
|
[x scopes*]
|
|
[:macro trans]
|
|
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))
|
|
(let [scopes* (conj scopes (new-scope))
|
|
keywords (nth datum 1)
|
|
rules (nthrest datum 2)]
|
|
(concat (list 'syntax-rules
|
|
keywords)
|
|
(for [[pattern template] rules]
|
|
(list pattern (resolve-template template scopes*))))))
|
|
|
|
(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))))
|
|
|
|
(defmethod expand-primitive 'begin
|
|
[datum _ env symtable-ref scopes]
|
|
(let [{:keys [body]} (s/conform ::prim-begin datum)]
|
|
(cons 'begin (map #(expand % env symtable-ref scopes) body))))
|
|
|
|
(comment
|
|
(let [env (:env scheme-base-env)
|
|
[_ trans] (get 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]
|
|
(let [{:keys [env symtable]} (scheme-base)]
|
|
(expand
|
|
datum env (atom symtable) #{})))
|
|
([datum env symtable-ref scopes]
|
|
(match datum
|
|
;; literals
|
|
(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)
|
|
(or (when-let [v (and (variable? f)
|
|
(offer-scopes f scopes))]
|
|
(match (lookup v env @symtable-ref)
|
|
[:primitive prim] (expand-primitive
|
|
datum prim env symtable-ref scopes)
|
|
[:macro trans] (expand-macro trans datum env symtable-ref scopes)
|
|
[:var] nil))
|
|
(cons (expand f env symtable-ref scopes)
|
|
(map #(expand % env symtable-ref scopes) xs))))))
|
|
|
|
|
|
|
|
(defn regensym
|
|
"Renumber the gensyms created by `new-scope` found in datum,
|
|
starting from zero."
|
|
[datum]
|
|
(let [c (atom {})]
|
|
(clojure.walk/postwalk
|
|
(fn [x]
|
|
(if (instance? Variable x)
|
|
(let [[sym scopes] (destructure-variable x)
|
|
syms (swap!
|
|
c
|
|
#(let [r (set/difference scopes
|
|
(set (keys %)))]
|
|
(into %
|
|
(map-indexed
|
|
(fn [n a]
|
|
[a (symbol (str "s" (+ (count %) n)))])
|
|
r))))]
|
|
#_(->Variable sym (set (map #(get syms %) scopes)))
|
|
[sym (set (map #(get syms %) scopes))])
|
|
x))
|
|
datum)))
|
|
|
|
(defn unscope
|
|
"Remove all scopes from the variables found in datum."
|
|
[datum]
|
|
(clojure.walk/postwalk
|
|
(fn [x]
|
|
(if (instance? Variable x)
|
|
(variable-symbol x)
|
|
x))
|
|
datum))
|
|
|
|
(defn us-expand [datum]
|
|
(unscope (expand datum)))
|
|
|
|
(defn rg-expand [datum]
|
|
(regensym (expand datum)))
|