[Guile-commits] 08/11: intmaps and intsets print with abbreviated key ranges

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 102e677b982fc1903b05c50b239a9f51d2e124f4
Author: Andy Wingo <address@hidden>
Date:   Tue May 19 10:19:02 2015 +0200

    intmaps and intsets print with abbreviated key ranges
    
    * module/language/cps/intset.scm (intset-key-ranges, range-string):
      (print-helper, print-intset, print-transient-intset): New helpers.
      Install as intset printers.
    * module/language/cps/intmap.scm (intmap-key-ranges, range-string):
      (print-helper): New helpers.
      (print-intmap, print-transient-intmap): Call the new helpers.
---
 module/language/cps/intmap.scm |   38 +++++++++++++++++++++++++++++++++-
 module/language/cps/intset.scm |   43 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 79 insertions(+), 2 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index d453731..cb56cb3 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -629,10 +629,44 @@
 (define (intmap->alist intmap)
   (reverse (intmap-fold acons intmap '())))
 
+(define (intmap-key-ranges intmap)
+  (call-with-values
+      (lambda ()
+        (intmap-fold (lambda (k v start end closed)
+                       (cond
+                        ((not start) (values k k closed))
+                        ((= k (1+ end)) (values start k closed))
+                        (else (values k k (acons start end closed)))))
+                     intmap #f #f '()))
+    (lambda (start end closed)
+      (reverse (if start (acons start end closed) closed)))))
+
+(define (range-string ranges)
+  (string-join (map (match-lambda
+                      ((start . start)
+                       (format #f "~a" start))
+                      ((start . end)
+                       (format #f "~a-~a" start end)))
+                    ranges)
+               ","))
+
+(define (print-helper port tag intmap)
+  (let ((ranges (intmap-key-ranges intmap)))
+    (match ranges
+      (()
+       (format port "#<~a>" tag))
+      (((0 . _) . _)
+       (format port "#<~a ~a>" tag (range-string ranges)))
+      (((min . end) . ranges)
+       (let ((ranges (map (match-lambda
+                            ((start . end) (cons (- start min) (- end min))))
+                          (acons min end ranges))))
+         (format port "#<~a ~a+~a>" tag min (range-string ranges)))))))
+
 (define (print-intmap intmap port)
-  (format port "#<intmap ~a>" (intmap->alist intmap)))
+  (print-helper port "intmap" intmap))
 (define (print-transient-intmap intmap port)
-  (format port "#<transient-intmap ~a>" (intmap->alist intmap)))
+  (print-helper port "transient-intmap" intmap))
 
 (set-record-type-printer! <intmap> print-intmap)
 (set-record-type-printer! <transient-intmap> print-transient-intmap)
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index 3276246..3d20797 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -27,6 +27,7 @@
 (define-module (language cps intset)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 match)
   #:export (empty-intset
             intset?
@@ -731,3 +732,45 @@
         (let ((min* (round-down pos *leaf-bits*)))
           (lp (finish-tail out min tail)
               min* pos (ash 1 (- pos min*)))))))))
+
+(define (intset-key-ranges intset)
+  (call-with-values
+      (lambda ()
+        (intset-fold (lambda (k start end closed)
+                       (cond
+                        ((not start) (values k k closed))
+                        ((= k (1+ end)) (values start k closed))
+                        (else (values k k (acons start end closed)))))
+                     intset #f #f '()))
+    (lambda (start end closed)
+      (reverse (if start (acons start end closed) closed)))))
+
+(define (range-string ranges)
+  (string-join (map (match-lambda
+                      ((start . start)
+                       (format #f "~a" start))
+                      ((start . end)
+                       (format #f "~a-~a" start end)))
+                    ranges)
+               ","))
+
+(define (print-helper port tag intset)
+  (let ((ranges (intset-key-ranges intset)))
+    (match ranges
+      (()
+       (format port "#<~a>" tag))
+      (((0 . _) . _)
+       (format port "#<~a ~a>" tag (range-string ranges)))
+      (((min . end) . ranges)
+       (let ((ranges (map (match-lambda
+                            ((start . end) (cons (- start min) (- end min))))
+                          (acons min end ranges))))
+         (format port "#<~a ~a+~a>" tag min (range-string ranges)))))))
+
+(define (print-intset intset port)
+  (print-helper port "intset" intset))
+(define (print-transient-intset intset port)
+  (print-helper port "transient-intset" intset))
+
+(set-record-type-printer! <intset> print-intset)
+(set-record-type-printer! <transient-intset> print-transient-intset)