commit 1ef7613daaa7157b47f22234c44d00f6f3a01e05
parent bd04ef6262b2875351519ef899e8795408ee15b4
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Tue, 17 Jan 2017 23:03:41 +0100
Got printing of the graph-info working
Diffstat:
3 files changed, 34 insertions(+), 41 deletions(-)
diff --git a/graph-info.hl.rkt b/graph-info.hl.rkt
@@ -132,10 +132,20 @@ data.
(define (to-datum v)
(syntax->datum (datum->syntax #f v)))
- (define (struct-printer2 ctor)
- (make-constructor-style-printer
- (λ (v) ctor)
- (λ (v) (map to-datum (struct->list v)))))
+ (define ((syntax-convert old-print-convert-hook)
+ val basic-convert sub-convert)
+ (cond
+ [(set? val)
+ (cons 'set (map sub-convert (set->list val)))]
+ [(and (hash? val) (immutable? val))
+ (cons 'hash
+ (append-map (λ (p) (list (sub-convert (car p))
+ (sub-convert (cdr p))))
+ (hash->list val)))]
+ [(syntax? val)
+ (list 'syntax (to-datum val))]
+ [else
+ (old-print-convert-hook val basic-convert sub-convert)]))
(define ((struct-printer ctor) st port mode)
(match-define (vector name fields ...) (struct->vector st))
@@ -162,42 +172,23 @@ data.
(display (to-datum f) port))
fields)
(display ")" port)]
- [(0)
- (display "(" port)
- (display short-name port)
- (for-each (λ (f)
- (display " " port)
- ;; Circumvent the undocumented(?) autodetection of
- ;; print which changes the behaviour if objects which
- ;; are not eq? to the original fields are directly
- ;; printed to the port.
- (let ([str (with-output-to-string
- (λ ()
- (print (to-datum f) (current-output-port) 0)))])
- (display (string-append str " ") port)))
- fields)
- (display ")" port)]
- [(1)
- (display "#(" port)
- (display name port)
- (for-each (λ (f)
- (display " " port)
- (display
- ;; Circumvent the undocumented(?) autodetection of
- ;; print which changes the behaviour if objects which
- ;; are not eq? to the original fields are directly
- ;; printed to the port.
- #;(with-output-to-string
- (λ ()
- (print (to-datum f) (current-output-port) 1)))
- "abab"
- port))
- fields)
- (display ")" port)]))]
+ [else
+ (let ([old-print-convert-hook (current-print-convert-hook)])
+ (parameterize ([constructor-style-printing #t]
+ [show-sharing #f]
+ [current-print-convert-hook
+ (syntax-convert old-print-convert-hook)])
+ (write
+ (cons short-name
+ (map print-convert
+ ;; to-datum doesn't work if I map it on the fields?
+ fields))
+ port)))]))]
@CHUNK[<*>
(require phc-toolkit/untyped
racket/struct
+ mzlib/pconvert
(for-syntax phc-toolkit/untyped
syntax/parse
syntax/parse/experimental/template))
diff --git a/graph-type.hl.rkt b/graph-type.hl.rkt
@@ -24,13 +24,14 @@
{~seq [root-node . _] _ …})
{~seq #:invariant a {~and op {~or ∈ ∋ ≡ ≢ ∉}} b} …
{~seq #:invariant p} …))))
-
+
(define-syntax/parse (define-graph-type . :signature)
(define gi <graph-info>)
(local-require racket/pretty)
- (pretty-print gi (current-output-port) 0)
+ (parameterize ([pretty-print-columns 188])
+ (pretty-print gi (current-output-port) 0))
#`(begin
- (define-syntax name #,gi)))]
+ #;(define-syntax name #,gi)))]
@chunk[<graph-info>
(graph-info #'name
@@ -84,7 +85,7 @@
phc-toolkit/untyped
(subtract-in syntax/parse phc-graph/subtemplate)
racket/set
- phc-graph/subtemplate))
+ phc-graph/subtemplate-override))
(provide define-graph-type)
diff --git a/info.rkt b/info.rkt
@@ -12,7 +12,8 @@
"delay-pure"
"backport-template-pr1514"
"typed-map"
- "scribble-lib"))
+ "scribble-lib"
+ "pconvert-lib"))
(define build-deps '("scribble-lib"
"racket-doc"
"remember"
