/collects/macro-debugger/syntax-browser/pretty-helper.rkt

http://github.com/gmarceau/PLT · Racket · 177 lines · 134 code · 14 blank · 29 comment · 16 complexity · 31350302a251f39c0547c98677ccc160 MD5 · raw file

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