Limited-depth strip-annotations

implementations/racket/preserves/main.rkt

@@ -51,21 +51,25 @@
   (with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
     (apply make-prefab-struct label fields)))
 
-(define (strip-annotations v)
-  (let walk ((v v))
-    (match v
-      [(annotated _ _ item)
-       (match item
-         [(record label fields) (build-record (walk label) (map walk fields))]
-         [(? non-object-struct?)
-          (error 'strip-annotations "Cannot strip-annotations from struct: ~v" v)]
-         [(? list?) (map walk item)]
-         [(? set?) (for/set [(i (in-set item))] (walk i))]
-         [(? dict?) (for/hash [((k v) (in-dict item))] (values (walk k) (walk v)))]
-         [(? annotated?)
-          (error 'strip-annotations "Improper annotation structure: ~v" v)]
-         [_ item])]
-      [_ v])))
+(define (strip-annotations v #:depth [depth +inf.0])
+  (let walk* ((v v) (depth depth))
+    (define next-depth (- depth 1))
+    (define (walk v) (walk* v next-depth))
+    (if (zero? depth)
+        v
+        (match v
+          [(annotated _ _ item)
+           (match item
+             [(record label fields) (build-record (walk* label depth) (map walk fields))]
+             [(? non-object-struct?)
+              (error 'strip-annotations "Cannot strip-annotations from struct: ~v" v)]
+             [(? list?) (map walk item)]
+             [(? set?) (for/set [(i (in-set item))] (walk i))]
+             [(? dict?) (for/hash [((k v) (in-dict item))] (values (walk k) (walk v)))]
+             [(? annotated?)
+              (error 'strip-annotations "Improper annotation structure: ~v" v)]
+             [_ item])]
+          [_ v]))))
 
 (define current-value->placeholder (make-parameter (lambda (v) #f)))
 (define current-placeholder->value (make-parameter (lambda (v) (void))))
@@ -943,8 +947,7 @@
       (newline)
       (write-preserve t #:indent #f)
       (newline)
-      (write-preserve (strip-annotations t) #:indent #t)
       (newline)
-      (newline)
-      (pretty-print (list t-name t))))
+      (pretty-print (list (strip-annotations t-name)
+                          (strip-annotations t #:depth 1)))))
   )