make internals accessible

info.rkt

@@ -0,0 +1,9 @@
+#lang info
+
+(define collection "json-view")
+
+(define deps '("base"
+               "gui-lib"
+               "breadcrumb"))
+
+(define build-deps '())

private/json-hierlist-item-mixin.rkt

@@ -10,14 +10,22 @@
 
 (define (get-color-from-preference name)
   (define pref (get-preference (string->symbol (~a color-key-prefix name))))
-  (apply make-object (cons color% (seventh (hash-ref pref 'classic)))))
+  (and pref
+       (hash-has-key? pref 'classic)
+       (apply make-object (cons color% (seventh (hash-ref pref 'classic))))))
 
 (define (make-style-delta style)
   (define delta (new style-delta%))
+  ; this is called many times
+  ; if this is skipped then nothing renders
+  (define foreground (get-color-from-preference style))
+  (when foreground
+    (send delta set-delta-foreground foreground))
   (send* delta
-    (set-delta-foreground (get-color-from-preference style))
     (set-face (get-preference font-name-key))
-    (set-size-add (vector-ref (get-preference font-size-key) 1))
+    (set-size-add
+     (let ([fsk (get-preference font-size-key)])
+       (or (and fsk (vector-ref fsk 1)) 14)))
     (set-size-mult 0))
   delta)
 

private/json-hierlist.rkt

@@ -10,7 +10,8 @@
   (class hierarchical-list%
     (init-field [on-item-select values])
     (define node-cache (make-hash))
-    (define root #f)
+    (define unexpanded (make-hash))
+    (field [root #f])
 
     (define/private (new-item-node parent)
       (send parent new-item json-hierlist-item-mixin))
@@ -33,7 +34,7 @@
         ((list? value) 'list)
         (else 'value)))
 
-    (define/private (create-key-value-tree parent parent-path key value kind style)
+    (define/private (create-key-value-tree parent parent-path key value kind style [once 0])
       (if (atom? value)
           (let ((node (new-item-node parent))
                 (path (reverse (cons key parent-path))))
@@ -45,16 +46,18 @@
             (hash-set! node-cache path node))
           (let ((node (new-list-node parent parent-path key kind style))
                 (path (cons key parent-path)))
-            (create-tree value node path))))
+            (if (< once 1)
+                (hash-set! unexpanded path value)
+                (create-tree value node path (sub1 once))))))
 
-    (define/private (create-tree jsexpr parent path)
+    (define/private (create-tree jsexpr parent path [once 1])
       (cond
         ((hash? jsexpr)
          (for (((key value) (in-hash jsexpr)))
-              (create-key-value-tree parent path key value (get-value-type value) 'key)))
+              (create-key-value-tree parent path key value (get-value-type value) 'key once)))
         ((list? jsexpr)
          (for (((value index) (in-indexed jsexpr)))
-              (create-key-value-tree parent path index value (get-value-type value) 'index)))
+              (create-key-value-tree parent path index value (get-value-type value) 'index once)))
         (else
          (let ((node (new-item-node parent))
                (path (reverse (cons jsexpr path))))
@@ -63,6 +66,16 @@
              (user-data (node-data 'value jsexpr jsexpr path)))
            (hash-set! node-cache path node)))))
 
+    (define/override (on-item-opened item)
+      (let ([items (send item get-items)])
+        (when (and (memq (node-data-type (send item user-data)) '(hash list))
+                   (null? items))
+          (let* ([nd (send item user-data)]
+                 [ndp (reverse (node-data-path nd))]
+                 [hr (hash-ref unexpanded ndp #f)])
+            (when hr
+              (create-tree hr item ndp))))))
+
     (define/override (on-select item)
       (when item
         (on-item-select (send item user-data))))

private/json-view.rkt

@@ -4,22 +4,25 @@
          "json-hierlist.rkt"
          "node-data.rkt")
 
-(provide json-view%)
+(provide json-view%
+         json-hierlist%
+         (struct-out node-data))
 
 (define json-view%
   (class vertical-panel%
     (super-new)
+    (init-field [hier-class% json-hierlist%])
 
-    (define path-bar (new breadcrumb%
+    (field [path-bar (new breadcrumb%
                           [parent this]
                           [callback (lambda (path)
-                                      (send json-hierlist select-path path))]))
+                                      (send json-hierlist select-path path))])])
 
-    (define json-hierlist (new json-hierlist%
+    (field [json-hierlist (new hier-class%
                                [parent this]
                                [on-item-select (lambda (data)
                                                  (send path-bar set-path!
-                                                       (node-data-path data)))]))
+                                                       (node-data-path data)))])])
 
     (define/public (get-json)
       (send json-hierlist get-json))

sample.rkt

@@ -1,7 +1,7 @@
 #lang racket/gui
 
 (require json
-         "json-view.rkt")
+         "private/json-view.rkt")
 
 (define sample
 #<<EOF