(ns scm
  (:require [instaparse.core :as insta]
            [clojure.java.io :as io]
            [clojure.core.match :refer [match]]
            [clojure.string :as str]
            [clojure.spec.alpha :as s])
  (:import clojure.lang.ILookup)
  (:refer-clojure :exclude [read]))


;;; syntax objects

(defprotocol ISyntax
  (syntax-e [this])
  (syntax-context [this]))

(defn syntax? [x]
  (satisfies? ISyntax x))

(deftype Syntax [datum ctx]
  Object
  (equals [x y]
    (or (identical? x y)
        (and (satisfies? ISyntax y)
             (.equals datum (syntax-e y))
             (.equals ctx (syntax-context y)))))
  ISyntax
  (syntax-e [this] datum)
  (syntax-context [this] ctx))

(defn unresolved? [stx]
  (= (syntax-context stx) ::unresolved))

(defn resolved? [stx]
  (not (unresolved? stx)))

(def ^:dynamic *print-ctx?* true)

;; does not respect `*print-dup*` lol
(defmethod print-method Syntax [this writer]
  (binding [*out* writer]
    (pr (tagged-literal
         'scm/stx
         (if (and *print-ctx?* (resolved? this))
           [(syntax-e this) (syntax-context this)]
           (syntax-e this))))))

(defmethod clojure.pprint/simple-dispatch Syntax [x]
  (clojure.pprint/simple-dispatch
   (tagged-literal
    'scm/stx
    (if (and *print-ctx?* (resolved? x))
      [(syntax-e x) (syntax-context x)]
      (syntax-e x)))))

(defn stx-reader [x]
  (if-let [[datum ctx] (and (vector? x) x)]
    (->Syntax datum ctx)
    (->Syntax x ::unresolved)))

(defn datum->syntax
  ([datum]
   (->Syntax datum ::unresolved))
  ([datum ctxt-donor]
   (->Syntax datum (syntax-context ctxt-donor))))

(defn identifier?
  "x가 신택스이고 x의 내용이 심볼이면 true를 생선함."
  [x]
  (and (syntax? x) (-> x syntax-e symbol?)))

(defn constant? [x]
  (or (and (syntax? x) (-> x syntax-e constant?))
      (number? x)
      (string? x)
      (boolean? x)))


;;; improper list

(deftype ImproperList [initial dot]
  Object
  (equals [x y]
    (or (identical? x y)
        (and (instance? ImproperList y)
             (.equals initial (:initial y))
             (.equals dot (:dot y)))))
  clojure.lang.ILookup
  (valAt [this k]
    (.valAt this k nil))
  (valAt [this k not-found]
    (case k
      :initial initial
      :dot dot
      not-found)))

(defn improper-list? [x]
  (instance? ImproperList x))

(defn improper-list [& xs]
  (assert (<= 2 (count xs))
          "improper list에는 최소 두 개 이상의 요소가 있어야 합니다")
  (->ImproperList (butlast xs) (last xs)))

;; does not respect `*print-dup*` lol
(defmethod print-method ImproperList [this writer]
  (print-method (concat (:initial this)
                        (list '. (:dot this)))
                writer))

(defmethod clojure.pprint/simple-dispatch ImproperList [this]
  (clojure.pprint/simple-dispatch
   (concat (:initial this)
           (list '. (:dot this)))))


;;; r⁷rs reader

(insta/defparser r7rs-parser (io/resource "r7rs.ebnf"))

(defn read
  "`read` 작업의 결과로 생성된 콘텍스트 필드는 초기에 비어 있다. 이후
  `expand/expand` 작업을 통해 콘택스트 필드를 패울 수 있다."
  [& {:keys [syntax? instaparse]
      :or {syntax? false
           instaparse {}}}]
  (let [r (insta/parse r7rs-parser (slurp *in*)
                       :start :datum-start
                       instaparse)]
    (if (insta/failure? r)
      r
      (insta/transform
       {:boolean (fn [x]
                   (match x
                     (:or "#t" "#true") true
                     (:or "#f" "#false") false))
        :datum-start identity
        ;; 그라머에 datum을 감추지 않은 고러서 대신 여기 모든 datum을
        ;; 과정할 수 있었더다. 작업 한 개만으로 syntax object들 다
        ;; 만들 수 있어서 이럼은 더 좋다.
        :datum (fn [x]
                 (datum->syntax x))
        :number identity
        :symbol symbol
        :string (fn [& els]
                  (apply str
                         (for [e els]
                           (match (into [] e)
                             [\\ \\] \\
                             [\\ \"] \\
                             [\\ \n] \newline
                             [c] c))))
        :list list
        :improper-list improper-list
        :sign (fn
                ([] identity)
                ([x] (match x "-" - "+" identity)))
        :num-10 (fn [sign digits]
                  (sign (parse-long digits)))}
       r))))

(defn read-syntax [& {:as opts}]
  (read (merge {:syntax? true} opts)))