Reimplement hy-repr with registered functions

This removes a lot of hy-reprs that were hard-coded into the hy-repr function itself. It also allows you to add a hy-repr for an existing class without monkey-patching the class.

hy/contrib/hy_repr.hy

@@ -7,92 +7,96 @@
   [hy._compat [PY3 str-type bytes-type long-type]]
   [hy.models [HyObject HyExpression HySymbol HyKeyword HyInteger HyFloat HyComplex HyList HyDict HySet HyString HyBytes]])
 
+(setv -registry {})
+(defn hy-repr-register [types f &optional placeholder]
+  (for [typ (if (instance? list types) types [types])]
+    (setv (get -registry typ) (, f placeholder))))
+
+(setv -quoting False)
+(setv -seen (set))
 (defn hy-repr [obj]
-  (setv seen (set))
-    ; We keep track of objects we've already seen, and avoid
-    ; redisplaying their contents, so a self-referential object
-    ; doesn't send us into an infinite loop.
-  (defn f [x q]
-    ; `x` is the current object being stringified.
-    ; `q` is True if we're inside a single quote, False otherwise.
-    (setv old? (in (id x) seen))
-    (.add seen (id x))
-    (setv t (type x))
-    (defn catted []
-      (if old? "..." (.join " " (list-comp (f it q) [it x]))))
-    (setv prefix "")
-    (if (and (not q) (instance? HyObject x))
-      (setv prefix "'"  q True))
-    (+ prefix (if
-      (hasattr x "__hy_repr__")
-        (.__hy-repr__ x)
-      (is t HyExpression)
-        (if (and x (symbol? (first x)))
-          (if
-            (= (first x) 'quote)
-              (+ "'" (f (second x) True))
-            (= (first x) 'quasiquote)
-              (+ "`" (f (second x) q))
-            (= (first x) 'unquote)
-              (+ "~" (f (second x) q))
-            (= (first x) 'unquote_splice)
-              (+ "~@" (f (second x) q))
-            (= (first x) 'unpack_iterable)
-              (+ "#* " (f (second x) q))
-            (= (first x) 'unpack_mapping)
-              (+ "#** " (f (second x) q))
-            ; else
-              (+ "(" (catted) ")"))
-          (+ "(" (catted) ")"))
-      (is t tuple)
-        (+ "(," (if x " " "") (catted) ")")
-      (in t [list HyList])
-        (+ "[" (catted) "]")
-      (is t HyDict)
-        (+ "{" (catted) "}")
-      (is t dict)
+  (setv [f placeholder] (next
+    (genexpr (get -registry t)
+      [t (. (type obj) __mro__)]
+      (in t -registry))
+    [-base-repr None]))
+
+  (global -quoting)
+  (setv started-quoting False)
+  (when (and (not -quoting) (instance? HyObject obj))
+    (setv -quoting True)
+    (setv started-quoting True))
+
+  (setv oid (id obj))
+  (when (in oid -seen)
+    (return (if (none? placeholder) "..." placeholder)))
+  (.add -seen oid)
+
+  (try
+    (+ (if started-quoting "'" "") (f obj))
+    (finally
+      (.discard -seen oid)
+      (when started-quoting
+        (setv -quoting False)))))
+
+(hy-repr-register list :placeholder "[...]" (fn [x]
+  (+ "[" (-cat x) "]")))
+(hy-repr-register tuple (fn [x]
+  (+ "(," (if x " " "") (-cat x) ")")))
+(hy-repr-register dict :placeholder "{...}" (fn [x]
+  (+ "{" (-cat (reduce + (.items x))) "}")))
+(hy-repr-register HyDict :placeholder "{...}" (fn [x]
+  (+ "{" (-cat x) "}")))
+(hy-repr-register [set HySet] (fn [x]
+  (+ "#{" (-cat x) "}")))
+(hy-repr-register frozenset (fn [x]
+  (+ "(frozenset #{" (-cat x) "})")))
+(hy-repr-register HyExpression (fn [x]
+  (setv syntax {
+    'quote "'"
+    'quasiquote "`"
+    'unquote "~"
+    'unquote_splice "~@"
+    'unpack_iterable "#* "
+    'unpack_mapping "#** "})
+  (if (and x (symbol? (first x)) (in (first x) syntax))
+    (+ (get syntax (first x)) (hy-repr (second x)))
+    (+ "(" (-cat x) ")"))))
+
+(hy-repr-register HySymbol str)
+(hy-repr-register [str-type bytes-type HyKeyword] (fn [x]
+  (if (and (instance? str-type x) (.startswith x HyKeyword.PREFIX))
+    (return (cut x 1)))
+  (setv r (.lstrip (-base-repr x) "ub"))
   (+
-          "{"
-          (if old? "..." (.join " " (list-comp
-            (+ (f k q) " " (f v q))
-            [[k v] (.items x)])))
-          "}")
-      (in t [set HySet])
-        (+ "#{" (catted) "}")
-      (is t frozenset)
-        (+ "(frozenset #{" (catted) "})")
-      (is t HySymbol)
-        x
-      (or (is t HyKeyword) (and (is t str-type) (.startswith x HyKeyword.PREFIX)))
-        (cut x 1)
-      (in t [str-type HyString bytes-type HyBytes]) (do
-        (setv r (.lstrip (base-repr x) "ub"))
-        (+ (if (in t [bytes-type HyBytes]) "b" "") (if (.startswith "\"" r)
+    (if (instance? bytes-type x) "b" "")
+    (if (.startswith "\"" r)
       ; If Python's built-in repr produced a double-quoted string, use
       ; that.
       r
       ; Otherwise, we have a single-quoted string, which isn't valid Hy, so
       ; convert it.
-          (+ "\"" (.replace (cut r 1 -1) "\"" "\\\"") "\""))))
-      (and (not PY3) (is t int))
-        (.format "(int {})" (base-repr x))
-      (and (not PY3) (in t [long_type HyInteger]))
-        (.rstrip (base-repr x) "L")
-      (and (in t [float HyFloat]) (isnan x))
-        "NaN"
-      (and (in t [float HyFloat]) (= x Inf))
-        "Inf"
-      (and (in t [float HyFloat]) (= x -Inf))
-        "-Inf"
-      (in t [complex HyComplex])
-        (.replace (.replace (.strip (base-repr x) "()") "inf" "Inf") "nan" "NaN")
-      (is t fraction)
-        (.format "{}/{}" (f x.numerator q) (f x.denominator q))
-      ; else
-        (base-repr x))))
-  (f obj False))
+      (+ "\"" (.replace (cut r 1 -1) "\"" "\\\"") "\"")))))
+(hy-repr-register bool str)
+(if (not PY3) (hy-repr-register int (fn [x]
+  (.format "(int {})" (-base-repr x)))))
+(if (not PY3) (hy-repr-register long_type (fn [x]
+  (.rstrip (-base-repr x) "L"))))
+(hy-repr-register float (fn [x]
+  (if
+    (isnan x)  "NaN"
+    (= x Inf)  "Inf"
+    (= x -Inf) "-Inf"
+               (-base-repr x))))
+(hy-repr-register complex (fn [x]
+  (.replace (.replace (.strip (-base-repr x) "()") "inf" "Inf") "nan" "NaN")))
+(hy-repr-register fraction (fn [x]
+  (.format "{}/{}" (hy-repr x.numerator) (hy-repr x.denominator))))
 
-(defn base-repr [x]
+(defn -cat [obj]
+  (.join " " (map hy-repr obj)))
+
+(defn -base-repr [x]
   (unless (instance? HyObject x)
     (return (repr x)))
   ; Call (.repr x) using the first class of x that doesn't inherit from

tests/native_tests/contrib/hy_repr.hy

@@ -4,7 +4,7 @@
 
 (import
   [math [isnan]]
-  [hy.contrib.hy-repr [hy-repr]])
+  [hy.contrib.hy-repr [hy-repr hy-repr-register]])
 
 (defn test-hy-repr-roundtrip-from-value []
   ; Test that a variety of values round-trip properly.
@@ -86,10 +86,24 @@
     (+ "{" (.join " " p) "}")
     [p (permutations ["1 2" "3 [4 {...}]" "6 7"])]))))
 
-(defn test-hy-repr-dunder-method []
-  (defclass C [list] [__hy-repr__ (fn [self] "cuddles")])
-  (assert (= (hy-repr (C)) "cuddles")))
+(defn test-hy-repr-custom []
+
+  (defclass C [object])
+  (hy-repr-register C (fn [x] "cuddles"))
+  (assert (= (hy-repr (C)) "cuddles"))
+
+  (defclass Container [object]
+    [__init__ (fn [self value]
+      (setv self.value value))])
+  (hy-repr-register Container :placeholder "(Container ...)" (fn [x]
+    (+ "(Container " (hy-repr x.value) ")")))
+  (setv container (Container 5))
+  (setv container.value container)
+  (assert (= (hy-repr container) "(Container (Container ...))"))
+  (setv container.value [1 container 3])
+  (assert (= (hy-repr container) "(Container [1 (Container ...) 3])")))
 
 (defn test-hy-repr-fallback []
-  (defclass D [list] [__repr__ (fn [self] "cuddles")])
+  (defclass D [object]
+    [__repr__ (fn [self] "cuddles")])
   (assert (= (hy-repr (D)) "cuddles")))