clojerl

;   Copyright (c) Rich Hickey. All rights reserved.
;   The use and distribution terms for this software are covered by the
;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;   which can be found in the file epl-v10.html at the root of this distribution.
;   By using this software in any fashion, you are agreeing to be bound by
;   the terms of this license.
;   You must not remove this notice, or any other, from this software.

(in-ns 'clojure.core)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; printing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(import '(erlang.io IWriter))

(set! *warn-on-infer* true)

(def ^:dynamic *print-meta* nil)

(def ^:dynamic
 ^{:doc "*print-length* controls how many items of each collection the
  printer will print. If it is bound to logical false, there is no
  limit. Otherwise, it must be bound to an integer indicating the maximum
  number of items of each collection to print. If a collection contains
  more items, the printer will print items up to the limit followed by
  '...' to represent the remaining items. The root binding is nil
  indicating no limit."
   :added "1.0"}
 *print-length* nil)

(def ^:dynamic
 ^{:doc "*print-level* controls how many levels deep the printer will
  print nested objects. If it is bound to logical false, there is no
  limit. Otherwise, it must be bound to an integer indicating the maximum
  level to print. Each argument to print is at level 0; if an argument is a
  collection, its items are at level 1; and so on. If an object is a
  collection and is at a level greater than or equal to the value bound to
  *print-level*, the printer prints '#' to represent it. The root binding
  is nil indicating no limit."
   :added "1.0"}
 *print-level* nil)

(def ^:dynamic *verbose-defrecords* false)

(def ^:dynamic
 ^{:doc "*print-namespace-maps* controls whether the printer will print
  namespace map literal syntax. It defaults to false, but the REPL binds
  to true."
   :added "1.9"}
  *print-namespace-maps* false)

(defn- print-sequential [begin, print-one, sep, end, sequence, ^IWriter w]
  (binding [*print-level* (and (not *print-dup*) *print-level* (dec *print-level*))]
    (if (and *print-level* (neg? *print-level*))
      (.write w "#")
      (do
        (.write w begin)
        (when-let [xs (seq sequence)]
          (if (and (not *print-dup*) *print-length*)
            (loop [xs xs
                   print-length *print-length*]
              (let [[x & xs] xs]
                (if (zero? print-length)
                  (.write w "...")
                  (do
                    (print-one x w)
                    (when xs
                      (.write w sep)
                      (recur xs (dec print-length)))))))
            (loop [xs xs]
              (let [[x & xs] xs]
                (print-one x w)
                (when xs
                  (.write w sep)
                  (recur xs))))))
        (.write w end)))))

(defn- print-meta [o, ^IWriter w]
  (when-let [m (meta o)]
    (when (and (pos? (count m))
               (or *print-dup*
                   (and *print-meta* *print-readably*)))
      (.write w "^")
      (if (and (= (count m) 1) (:tag m))
          (pr-on (:tag m) w)
          (pr-on m w))
      (.write w " "))))

(defn print-simple [o ^IWriter w]
  (print-meta o w)
  (.write w (str o)))

(defmethod print-method :default [o, ^IWriter w]
  (print-simple o w))

(defmethod print-method nil [o, ^IWriter w]
  (.write w "nil"))

(defmethod print-dup nil [o ^IWriter w] (print-method o w))

(defn- print-tagged-object [o rep ^IWriter w]
  (when (instance? clojerl.IMeta o)
    (print-meta o w))
  (.write w "#object[")
  (let [^erlang.Type t (type o)]
    (.write w (.str t)))
  (.write w " ")
  (.write w (format "0x~.16B " (erlang/phash2 o)))
  (print-method rep w)
  (.write w "]"))

(defn- print-object [o, ^IWriter w]
  (print-tagged-object o (str o) w))

#_(defmethod print-method :default [o, ^IWriter w]
  (print-object o w))

(defmethod print-method clojerl.Keyword [o, ^IWriter w]
  (.write w (str o)))

(defmethod print-dup clojerl.Keyword [o ^IWriter w] (print-method o w))

(defmethod print-method clojerl.Integer [o, ^IWriter w]
  (.write w (str o)))

(defmethod print-dup clojerl.Integer [o, ^IWriter w] (print-method o w))

(defmethod print-method clojerl.Float [o, ^IWriter w]
  (.write w (str o)))

(defmethod print-dup clojerl.Float [o, ^IWriter w] (print-method o w))

(defmethod print-method clojerl.Boolean [o, ^IWriter w]
  (.write w (str o)))

(defmethod print-dup clojerl.Boolean [o ^IWriter w] (print-method o w))

(defmethod print-method clojerl.Symbol [o, ^IWriter w]
  (print-simple o w))

(defmethod print-dup clojerl.Symbol [o ^IWriter w] (print-method o w))

(defmethod print-method clojerl.Var [o, ^IWriter w]
  (print-simple o w))

(defmethod print-dup clojerl.Var [o, ^IWriter w]
  (.write w (str "#=(var " (namespace o) "/" (name o) ")")))

(defmethod print-dup clojerl.Namespace [^clojerl.Namespace n ^IWriter w]
  (.write w "#=(find-ns ")
  (print-dup (.name n) w)
  (.write w ")"))

(defmethod print-method clojerl.Namespace [^clojerl.Namespace n ^IWriter w]
  (.write w "#<clojerl.Namespace ")
  (.write w (.str n))
  (.write w ">"))

(defmethod print-method clojerl.List [o, ^IWriter w]
  (print-meta o w)
  (print-sequential "(" pr-on " " ")" o w))

(defmethod print-method erlang.List [o, ^IWriter w]
  (print-meta o w)
  (if (io_lib/printable_unicode_list o)
    (.write w (str "#erl\"" (unicode/characters_to_binary o) "\""))
    (print-sequential "#erl(" pr-on " " ")" o w)))

(defmethod print-method clojerl.Cons [o, ^IWriter w]
  (print-meta o w)
  (print-sequential "(" pr-on " " ")" o w))

(defmethod print-method clojerl.LazySeq [o, ^IWriter w]
  (print-meta o w)
  (print-sequential "(" pr-on " " ")" o w))

(defmethod print-method clojerl.Range [o, ^IWriter w]
  (print-meta o w)
  (print-sequential "(" pr-on " " ")" o w))

(defmethod print-dup clojerl.List [o ^IWriter w] (print-method o w))
(defmethod print-dup erlang.List [o ^IWriter w] (print-method o w))
(defmethod print-dup clojerl.Cons [o ^IWriter w] (print-method o w))
(defmethod print-dup clojerl.LazySeq [o ^IWriter w] (print-method o w))
(defmethod print-dup clojerl.Range [o ^IWriter w] (print-method o w))

(def ^{:tag clojerl.String
       :doc "Returns escape string for char or nil if none"
       :added "1.0"}
  char-escape-string
    {\newline "\\n"
     \tab  "\\t"
     \return "\\r"
     \" "\\\""
     \\  "\\\\"
     \formfeed "\\f"
     \backspace "\\b"})

(defmethod print-method clojerl.String [^clojerl.String s, ^IWriter w]
  (if (or *print-dup* *print-readably*)
    (let [printable? (.is_printable s)]
      (.write w (if printable? \" "#bin["))
      (if printable?
        (let [chars (map #(or (char-escape-string %) %) s)
              s     (apply str chars)]
          (.write w s))
        (->> (erlang/binary_to_list s)
             (interpose " ")
             (apply str)
             (.write w)))
      (.write w (if printable? \" "]")))
    (.write w s))
  nil)

(defmethod print-dup clojerl.String [s ^IWriter w] (print-method s w))

(defmethod print-method clojerl.Vector [v, ^IWriter w]
  (print-meta v w)
  (print-sequential "[" pr-on " " "]" v w))

(defmethod print-method clojerl.Subvec [v, ^IWriter w]
  (print-meta v w)
  (print-sequential "[" pr-on " " "]" v w))

(defn- print-prefix-map [prefix m print-one w]
  (print-sequential
    (str prefix "{")
    (fn [e ^IWriter w]
      (do (print-one (key e) w) (.write w \space) (print-one (val e) w)))
    ", "
    "}"
    (seq m) w))

(defn- print-map [m print-one w]
  (print-prefix-map nil m print-one w))

(defn- strip-ns
  [named]
  (if (symbol? named)
    (symbol nil (name named))
    (keyword nil (name named))))

(defn- lift-ns
  "Returns [lifted-ns lifted-map] or nil if m can't be lifted."
  [m]
  (when *print-namespace-maps*
    (loop [ns nil
           [[k v :as entry] & entries] (seq m)
           lm {}]
      (if entry
        (when (or (keyword? k) (symbol? k))
          (if ns
            (when (= ns (namespace k))
              (recur ns entries (assoc lm (strip-ns k) v)))
            (when-let [new-ns (namespace k)]
              (recur new-ns entries (assoc lm (strip-ns k) v)))))
        [ns (apply conj (empty m) lm)]))))

(defmethod print-method clojerl.Map [m, ^IWriter w]
  (print-meta m w)
  (let [[ns lift-map] (lift-ns m)]
    (if ns
      (print-prefix-map (str "#:" ns) lift-map pr-on w)
      (print-map m pr-on w))))

(defmethod print-method clojerl.SortedMap [m, ^IWriter w]
  (print-meta m w)
  (print-map m pr-on w))

(defmethod print-method clojerl.TupleMap [m, ^IWriter w]
  (print-meta m w)
  (print-map m pr-on w))

(defmethod print-method erlang.Map [m, ^IWriter w]
  (print-meta m w)
  (print-prefix-map "#erl" m pr-on w))

(defmethod print-method clojerl.Set [s, ^IWriter w]
  (print-meta s w)
  (print-sequential "#{" pr-on " " "}" (seq s) w))

(defmethod print-method clojerl.SortedSet [s, ^IWriter w]
  (print-meta s w)
  (print-sequential "#{" pr-on " " "}" (seq s) w))

(defmethod print-method erlang.Tuple [s, ^IWriter w]
  (print-meta s w)
  (print-sequential "#erl[" pr-on " " "]" (seq s) w))

(defn- deref-as-map [^clojerl.IDeref o]
  (let [[ex val]
        (try [false (deref o)]
             (catch :error e
               [true e]))]
    {:status
     (cond
      ex
      :failed

      :else
      :ready)

     :val val}))

(defmethod print-method clojerl.Atom [o ^IWriter w]
  (print-tagged-object o (deref-as-map o) w))

(defn IError->map
  "Constructs a data representation for a IError with keys:
    :type - exception type symbol
    :message - exception message
    :data - ex-data"
  {:added "1.7"}
  [^clojerl.IError o]
  (merge {:type (symbol (str (type o)))}
         (when-let [msg (.message o)]
           {:message msg})
         (when-let [ed (ex-data o)]
           {:data ed})
         (when-let [cause (ex-cause o)]
           {:cause (IError->map cause)})))

(defn- print-error [^clojerl.IError o ^IWriter w]
  (.write w "#error {")
  (let [{:keys [type message data cause]} (IError->map o)]
    (.write w "\n :type ")
    (print-method type w)
    (when message
      (.write w "\n :message ")
      (print-method message w))
    (when data
      (.write w "\n :data ")
      (print-method data w))
    (when cause
      (.write w "\n :cause ")
      (print-method cause w)))
  (.write w "}"))

(defmethod print-method clojerl.Error [^clojerl.Error o ^IWriter w]
  (print-error o w))

(defmethod print-method clojerl.ExceptionInfo [^clojerl.ExceptionInfo o ^IWriter w]
  (print-error o w))

(defmethod print-method clojerl.reader.TaggedLiteral [o ^IWriter w]
  (.write w "#")
  (print-method (:tag o) w)
  (.write w " ")
  (print-method (:form o) w))

(defmethod print-method clojerl.reader.ReaderConditional [o ^IWriter w]
  (.write w "#?")
  (when (:splicing? o) (.write w "@"))
  (print-method (:form o) w))

;; Even though this is not the same as in Clojure JVM, it is still
;; true since the on_load code will be evaluated before the value for
;; this Var can even returned.
(def ^:dynamic ^{:private true} print-initialized true)