pretty-helper.rkt (7387B)
1 #lang racket/base 2 (require racket/pretty 3 racket/class/iop 4 racket/struct 5 "interfaces.rkt" 6 "../model/stx-util.rkt") 7 (provide (all-defined-out)) 8 9 ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it 10 ;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are 11 ;; indistinguishable. 12 13 ;; Solution: Rather than map stx to (syntax-e stx), in the cases where 14 ;; (syntax-e stx) is confusable, map it to a different, unique, value. 15 ;; Use syntax-dummy, and extend pretty-print-remap-stylable to look inside. 16 17 ;; Old solution: same, except map identifiers to uninterned symbols instead 18 19 ;; NOTE: Nulls are only wrapped when *not* list-terminators. 20 ;; If they were always wrapped, the pretty-printer would screw up 21 ;; list printing (I think). 22 23 ;; UPDATE: In fact, want to treat all atomic values as confusable. The recent 24 ;; reader change (interning strings, etc) highlights the issue. 25 26 (define (pretty-print/defaults datum [port (current-output-port)]) 27 (parameterize 28 (;; Printing parameters (defaults from MzScheme and DrScheme 4.2.2.2) 29 [print-unreadable #t] 30 [print-graph #f] 31 [print-struct #t] 32 [print-box #t] 33 [print-vector-length #f] 34 [print-hash-table #t]) 35 (pretty-write datum port))) 36 37 (define-struct syntax-dummy (val)) 38 (define-struct (id-syntax-dummy syntax-dummy) (remap)) 39 40 ;; A SuffixOption is one of 41 ;; - 'never -- never 42 ;; - 'always -- suffix > 0 43 ;; - 'over-limit -- suffix > limit 44 ;; - 'all-if-over-limit -- suffix > 0 if any over limit 45 46 ;; syntax->datum/tables : stx partition% num SuffixOption 47 ;; -> (values s-expr hashtable hashtable) 48 ;; When partition is not false, tracks the partititions that subterms belong to 49 ;; When limit is a number, restarts processing with numbering? set to true 50 ;; 51 ;; Returns three values: 52 ;; - an S-expression 53 ;; - a hashtable mapping S-expressions to syntax objects 54 ;; - a hashtable mapping syntax objects to S-expressions 55 ;; Syntax objects which are eq? will map to same flat values 56 (define (syntax->datum/tables stx partition limit suffixopt abbrev?) 57 (table stx partition limit suffixopt abbrev?)) 58 59 ;; table : syntax maybe-partition% maybe-num SuffixOption boolean -> (values s-expr hashtable hashtable) 60 (define (table stx partition limit suffixopt abbrev?) 61 (define (make-identifier-proxy id) 62 (define sym (syntax-e id)) 63 (case suffixopt 64 ((never) 65 (make-id-syntax-dummy sym sym)) 66 ((always) 67 (let ([n (send/i partition partition<%> get-partition id)]) 68 (if (zero? n) 69 (make-id-syntax-dummy sym sym) 70 (make-id-syntax-dummy (suffix sym n) sym)))) 71 ((over-limit) 72 (let ([n (send/i partition partition<%> get-partition id)]) 73 (if (<= n limit) 74 (make-id-syntax-dummy sym sym) 75 (make-id-syntax-dummy (suffix sym n) sym)))))) 76 77 (let/ec escape 78 (let ([flat=>stx (make-hasheq)] 79 [stx=>flat (make-hasheq)]) 80 (define (loop obj) 81 (cond [(hash-ref stx=>flat obj (lambda _ #f)) 82 => (lambda (datum) datum)] 83 [(and partition (identifier? obj)) 84 (when (and (eq? suffixopt 'all-if-over-limit) 85 (> (send/i partition partition<%> count) limit)) 86 (call-with-values (lambda () (table stx partition #f 'always abbrev?)) 87 escape)) 88 (let ([lp-datum (make-identifier-proxy obj)]) 89 (hash-set! flat=>stx lp-datum obj) 90 (hash-set! stx=>flat obj lp-datum) 91 lp-datum)] 92 [(and (syntax? obj) abbrev? (check+convert-special-expression obj)) 93 => (lambda (newobj) 94 (when partition (send/i partition partition<%> get-partition obj)) 95 (let* ([inner (cadr newobj)] 96 [lp-inner-datum (loop inner)] 97 [lp-datum (list (car newobj) lp-inner-datum)]) 98 (hash-set! flat=>stx lp-inner-datum inner) 99 (hash-set! stx=>flat inner lp-inner-datum) 100 (hash-set! flat=>stx lp-datum obj) 101 (hash-set! stx=>flat obj lp-datum) 102 lp-datum))] 103 [(syntax? obj) 104 (when partition (send/i partition partition<%> get-partition obj)) 105 (let ([lp-datum (loop (syntax-e* obj))]) 106 (hash-set! flat=>stx lp-datum obj) 107 (hash-set! stx=>flat obj lp-datum) 108 lp-datum)] 109 ;; -- Traversable structures 110 [(pair? obj) 111 (pairloop obj)] 112 [(prefab-struct-key obj) 113 => (lambda (pkey) 114 (let-values ([(refold fields) (unfold-pstruct obj)]) 115 (refold (map loop fields))))] 116 [(vector? obj) 117 (list->vector (map loop (vector->list obj)))] 118 [(box? obj) 119 (box (loop (unbox obj)))] 120 [(hash? obj) 121 (let ([constructor 122 (cond [(hash-equal? obj) make-immutable-hash] 123 [(hash-eqv? obj) make-immutable-hasheqv] 124 [(hash-eq? obj) make-immutable-hasheq])]) 125 (constructor 126 (for/list ([(k v) (in-hash obj)]) 127 (cons k (loop v)))))] 128 ;; -- Atoms ("confusable") 129 [(symbol? obj) 130 (make-id-syntax-dummy obj obj)] 131 [else ;; null, boolean, number, keyword, string, bytes, char, regexp, 3D vals 132 (make-syntax-dummy obj)])) 133 (define (pairloop obj) 134 (cond [(pair? obj) 135 (cons (loop (car obj)) 136 (pairloop (cdr obj)))] 137 [(null? obj) 138 null] 139 [(and (syntax? obj) (null? (syntax-e obj))) 140 null] 141 [else (loop obj)])) 142 (values (loop stx) 143 flat=>stx 144 stx=>flat)))) 145 146 ;; unfold-pstruct : prefab-struct -> (values (list -> prefab-struct) list) 147 (define (unfold-pstruct obj) 148 (define key (prefab-struct-key obj)) 149 (define fields (struct->list obj)) 150 (values (lambda (new-fields) 151 (apply make-prefab-struct key new-fields)) 152 fields)) 153 154 ;; check+convert-special-expression : syntax -> #f/syntaxish 155 (define (check+convert-special-expression stx) 156 (define stx-list (stx->list* stx)) 157 (and stx-list (= 2 (length stx-list)) 158 (let ([kw (car stx-list)] 159 [expr (cadr stx-list)]) 160 (and (identifier? kw) 161 (memq (syntax-e kw) special-expression-keywords) 162 (bound-identifier=? kw (datum->syntax stx (syntax-e kw))) 163 (andmap (lambda (f) (equal? (f stx) (f kw))) 164 (list syntax-source 165 syntax-line 166 syntax-column 167 syntax-position 168 syntax-original? 169 syntax-source-module)) 170 (cons (syntax-e kw) 171 (list expr)))))) 172 173 (define special-expression-keywords 174 '(quote quasiquote unquote unquote-splicing syntax 175 quasisyntax unsyntax unsyntax-splicing)) 176 177 (define (suffix sym n) 178 (string->symbol (format "~a:~a" sym n)))