pretty-print-collapse-s-expr.rkt

#lang racket/base

(require racket/list
         racket/match
         racket/class
         racket/pretty
         racket/snip
         racket/gui/base
         framework)

(provide sexp-pp traces/sexp-pp)

#|
Examples:
    (sexp-pp '(hello (store world) !))
    (define-language L)
    (define R (reduction-relation L (--> variable ((store variable) variable))))
    (traces/sexp-pp R 'x)
Side notes:
- The output area in the REPL is locked, but expanding the S-exps
  is an editing operation. Therefore (...)s have to be copied to
  the prompt area (> ).
- racket:sexp-snip%s don't respond to clicks. Instead, there is an
  "Expand S-expression" item in the context menu.
|#

(define sexp-pp-write-special? (make-parameter #f))

(define (sexp-pp v
                 #:print-columns [print-columns #f]
                 #:minimum-columns [minimum-columns 20]
                 . args)
  (unless (void? v)
    (define old-size-hook (pretty-print-size-hook))
    (define old-print-hook (pretty-print-print-hook))
    (parameterize ([pretty-print-columns (or print-columns (pretty-print-columns))]
                   [pretty-print-size-hook
                    (λ (v display-mode? out-port)
                      (cond
                        [(port-writes-special? out-port)
                         (match v
                           #| REPLACE THIS WITH YOUR OWN PATTERN AND SIZE HOOK |#
                           [`(store . ,_)
                            1]
                           [_ #f])]
                        [else #f]))]
                   [pretty-print-print-hook
                    (λ (v display-mode? out-port)
                      (define-values (line col pos)
                        (port-next-location out-port))
                      (define remaining-width
                        (max minimum-columns
                             (- (pretty-print-columns) col)))
                      (define text
                        (new racket:text%))
                      (define latest-size-hook (pretty-print-size-hook))
                      (parameterize ([current-output-port (open-output-text-editor text)]
                                     [sexp-pp-write-special? #t]
                                     [pretty-print-size-hook
                                      (λ (new-v display-mode? out-port)
                                        (and (not (equal? v new-v))
                                             (latest-size-hook new-v
                                                               display-mode?
                                                               out-port)))])
                        (port-count-lines! (current-output-port))
                        (write-string (build-string col (λ (index) #\space)))
                        (pretty-write v #:newline? #f))
                      (send text split-snip col)
                      (define snips
                        (let loop ([snip (send text find-snip col 'after)])
                          (if snip
                              (cons (send snip copy) (loop (send snip next)))
                              '())))
                      #|
                           For simplicity, you can also create ordinary string-snip%s
                           containing the formatted expression and send it to the
                           `saved-snips` field without going through a separate
                           text% editor.

                           To maintain linebreaks without text%, create multiple
                           string-snip%s and use the following string snip in place
                           of the newline character:

                           (define nl (make-object string-snip% "\n"))
                           (send nl set-flags '(is-text invisible newline hard-newline))
                      |#
                      (define s
                        (new racket:sexp-snip%
                             [left-bracket #\(]
                             [right-bracket #\)]
                             [saved-snips snips]))
                      (cond
                        [(sexp-pp-write-special?)
                         (write-special s out-port)]
                        [else
                         (old-print-hook s display-mode? out-port)]))])
      (apply pretty-print v args))))


(require redex/reduction-semantics redex/gui)
(define (traces/sexp-pp R t)
  (traces R t #:pp (λ (term out-port print-columns text)
                     (parameterize ([sexp-pp-write-special? #t])
                       (sexp-pp term out-port
                                #:print-columns print-columns)))))

;; Examples
(module+ main
  (define-language L
    [e ::= integer (+ e e) (store e ...)])

  (define R
    (compatible-closure
     (reduction-relation L
                         (--> integer_1 integer_2
                              (where #t ,(> (term integer_1) 0))
                              (where integer_2 ,(- (term integer_1) 1))))
     L
     e))

  (traces/sexp-pp
   R
   '(store (+ 2 1)
           (store 3)))

  (sexp-pp '(store (+ 2 1)
                   (store 3)))
  )

Collapsed S-expressions in the REPL:

Collapsed S-expressions in the traces window:

(The line breaks are yet to be fixed.)