prototype-r7rs-expander/src/expand.clj

(ns expand
  (:require [clojure.core.match :refer [match]]
            [clojure.pprint]
            [clojure.set :as set]
            [clojure.spec.alpha :as s]
            [clojure.walk]
            [spec-dict.main :refer [dict]]
            [scm]))

(s/def ::scope symbol?)

(s/def ::binding
  #(match %
     [:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
     [:global sym] (symbol? sym)))

(s/def ::context (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 map, as Symbol → Scopes →
;; Binding. however, this is a bit more error-prone and cumbersome for
;; a prototype.
(s/def ::store
  (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?))
            ::binding))

(def primitives
  "A set of symbols to be defined as primitive syntax exposed by
  (scheme base)."
  '#{let let-syntax letrec lambda syntax-rules if define
     define-syntax begin})

(def builtins
  "A set of symbols to be defined as variables exposed by (scheme
  base)."
  '#{+ * / - car cdr write display newline cons list})

(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 ::syntax scm/syntax?)

(s/def ::identifier scm/identifier?)

(s/fdef expand
  :args (s/cat :stx ::syntax
               :env ::environment
               :store ::store)
  :ret ::syntax)

(s/fdef lookup
  :args (s/cat :ident ::identifier
               :env ::environment
               :store ::store))

(s/fdef nearest
  :args (s/cat :ctx ::context
               :ss (s/coll-of ::context))
  :ret (s/coll-of ::context :kind set?))

(s/fdef new-scope
  :args (s/cat :prefix (s/? string?))
  :ret ::scope)


;;; prim specs

(s/def ::datum scm/datum?)

(s/def ::unsyntax
  (s/conformer
   (fn [x]
     (match x
       (_ :guard scm/syntax?) (scm/syntax-e x)
       _ ::s/invalid))))

(s/def ::body
  (s/+ ::datum))

(s/def ::lambda-formals
  (s/and ::unsyntax
         #(or (and (list? %) (apply (every-pred scm/identifier?) %))
              scm/improper-list?
              scm/identifier?)))

(s/def ::prim-lambda
  (s/and ::unsyntax
         (s/cat :keyword ::identifier
          :formals ::lambda-formals
          :body ::body)))



(defn new-scope
  ([] (gensym "scope__"))
  ([prefix] (gensym (str "scope__" prefix))))

#_
(defn bind-lexical [sym denot store-atom]
  (let [bind [:lexical sym (gensym)]]
    (swap! store-atom #(assoc % [sym scopes] bind))
    {bind denot}))

#_
(s/fdef binding-form
  :args (s/cat :binds (s/coll-of (s/tuple symbol? ::denotation))
               :store-atom #(instance? clojure.lang.Atom %)
               :datum ::datum))

(defn binding-form [ident env store-atom binds f]
  (let [scopes (conj (scm/syntax-context ident)
                     (new-scope))
        ident* (scm/->Syntax (scm/syntax-e ident)
                             scopes)
        additions (for [[sym denot] binds]
                    [sym
                     [:lexical sym (gensym)]
                     denot])
        env* (into env (for [[_sym bind denot] additions]
                         [bind denot]))]
    (swap! store-atom #(into % (for [[sym bind _denot] binds]
                                 [[sym scopes] bind])))
    (scm/datum->syntax (cons
                        ;; 여기서 ident를 써야 할지 ident*를 써야 할지 몰라…
                        (scm/syntax-e ident)
                        (f ident* env*))
                       ident)))

(comment
  (let [env {}
        store-atom (atom {})]
    (binding-form #scm/stx [lambda #{}]
                  env
                  store-atom
                  {:x [:var]}
                  (fn [ident* env*]
                    (tap> {:ident* ident*
                           :env* env*})
                    (list (scm/datum->syntax 'x ident*))))))



(defn- store-scopes
  "Gather the set of scope-sets associated with a given symbol."
  [store sym]
  (into #{} (for [[[x scopes] _] store
                  :when (= sym x)]
              scopes)))

(defn nearest [ctx ss]
  (let [xs (->> ss
                (filter #(set/subset? % ctx))
                (group-by count)
                seq)]
    (set (some->> xs (apply max-key first) second))))

(defn lookup [ident env store]
  (let [sym (scm/syntax-e ident)
        scopes (scm/syntax-context ident)
        ss (store-scopes store sym)]
    (let [xs (nearest scopes ss)
          r (compare (count xs) 1)]
      (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
            (zero? r)
            (or (get env (or (get store [sym (first xs)])
                             (throw (ex-info "unreachable" {}))))
                (throw (ex-info "unreachable" {})))
            (pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))))

(declare expand)

(defmulti expand-primitive
  (fn [_datum prim-name _env _store-atom]
    prim-name))

#_
(defmethod expand-primitive 'lambda
  [stx _ env symtable-ref]
  (let [{:keys [formals body]} (->> stx
                                    scm/syntax-e
                                    (s/conform ::prim-lambda))]
    (concat (list 'lambda
                  (throw (Exception. "todo2")))
            (for [e body]
              (expand e env* symtable-ref)))))

(defn expand [stx env store-atom]
  (match (scm/syntax-e stx)
    (x :guard scm/constant?) x
    (x :guard scm/identifier?)
    (do (lookup x env @store-atom) ; throw if unbound
        x)

    ([f & xs] :seq)
    (or (when (scm/identifier? f)
          (match (lookup f env @store-atom)
            [:primitive prim] (expand-primitive stx prim env store-atom)
            #_#_[:macro trans] (expand-macro trans datum env symtable-ref scopes)
            [:var] nil))
        (cons (expand f env store-atom)
              (map #(expand % env store-atom) xs)))))

(defn expand-library [lib])