Skip to content

Commit d6c47e6

Browse files
jmctjmct
committed
Got pretty-printing working
Some thoughts: * I think I need to do less logic in render-ast.rkt and more in dot.rkt * Lots of n^2 behavior
1 parent 0db692b commit d6c47e6

6 files changed

Lines changed: 389 additions & 8 deletions

File tree

‎www/notes/knock/dot.rkt‎

Lines changed: 200 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,200 @@
1+
#lang racket
2+
(provide (all-defined-out))
3+
4+
(require "pretty-printer.rkt")
5+
6+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7+
;;;;; top-level graph
8+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9+
10+
; A graph is its name along with its list of contents
11+
; graph : String [Content] -> Graph
12+
(struct graph (name conts) #:transparent)
13+
14+
; A subgraph is its name along with its list of contents
15+
; subgraph : String [Content] -> Graph
16+
(struct subgraph (name conts) #:transparent)
17+
18+
; type Content =
19+
; | Node
20+
; | Edge
21+
; | ToMany ; Edge from one shared parent to many targets
22+
; | Attribute
23+
; | Subgraph
24+
25+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26+
;;;;; Graph internal structures
27+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28+
29+
;;;;; Nodes
30+
31+
; type Node =
32+
; | String <- Just a node
33+
; | Symbol <- Just a node
34+
; | (String, [Property]) <- A node and some property
35+
; | SubG <- Subgraph (i.e. a set of nodes)
36+
37+
; An edge defines the origin node and the target node by name
38+
; edge : Node Node [Property] -> Content
39+
(struct edge (orig targ props) #:transparent)
40+
41+
; When one origin has many targets
42+
; edge : Node [Node] [Property] -> Content
43+
(struct to-many (orig targs props) #:transparent)
44+
45+
; An attribute described whether it applies to the edges or
46+
; nodes and also has a list of properties
47+
; attr : Symbol [Property] -> Content
48+
(struct attr (type props) #:transparent)
49+
50+
; A property is a parameter and its value
51+
(struct prop (par val) #:transparent)
52+
53+
; Pair
54+
(struct pair (a b) #:transparent)
55+
56+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57+
;;;;; Constructors
58+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
59+
60+
; Make an edge between two nodes with no properties
61+
; e : Node Node -> Content
62+
(define (e n1 n2)
63+
(edge n1 n2 '()))
64+
65+
; Make edges between a list of nodes
66+
; es [Node] -> [Content]
67+
(define (es ns)
68+
(match ns
69+
[(cons n1 (cons n2 '())) (cons (edge n1 n2 '()) '())]
70+
[(cons n1 (cons n2 ns)) (cons (edge n1 n2 '()) (es (cons n2 ns)))]
71+
[_ (error "There must be at least 2 nodes given to es")]))
72+
73+
(define (tm n1 ns)
74+
(to-many n1 ns '()))
75+
76+
; Set a node to a specific shape
77+
; There are many, but we'll start with:
78+
; * box
79+
; * oval
80+
; * circle
81+
; * diamond
82+
; * rect
83+
;
84+
; shape : Symbol Node -> Node
85+
(define (shape sh node)
86+
(match node
87+
[(? string? n) (pair n (list (prop 'shape sh)))]
88+
[(? symbol? n) (pair (symbol->string n) (list (prop 'shape sh)))]
89+
[(pair n props) (pair n (cons (prop 'shape sh) props))]))
90+
91+
; Attach meta-data to content, the parameter must be passed
92+
; as a label
93+
; attach : Symbol Symbol Content -> Content
94+
(define (attach param st cont)
95+
(match cont
96+
; Nodes
97+
[(? string? n) (pair n (list (prop param st)))]
98+
[(? symbol? n) (pair (symbol->string n) (list (prop param st)))]
99+
[(pair n props) (pair n (cons (prop param st) props))]
100+
; Edges
101+
[(edge o t props) (edge o t (cons (prop param st) props))]
102+
[(to-many o t props) (to-many o t (cons (prop param st) props))]
103+
; Attribute
104+
[(attr t props) (attr t (cons (prop param st) props))]))
105+
106+
; Color some Content
107+
; Known colors:
108+
; * red
109+
; * blue
110+
; * black
111+
; * darkgreen
112+
; * brown
113+
; * deeppink2
114+
(define (color val cont)
115+
(attach 'color (string->symbol val) cont))
116+
117+
; Set the style of some contents
118+
; There are many, but we'll start with:
119+
; * dashed
120+
; * dotted
121+
; * bold
122+
;
123+
; style : Symbol Content -> Content
124+
(define (style st cont)
125+
(attach 'style st cont))
126+
127+
; Attach a label to Content
128+
(define (label lab cont)
129+
(attach 'label (string->symbol lab) cont))
130+
131+
; Attach a label to Content
132+
(define (label-str lab str)
133+
(attach 'label (string->symbol lab) (string->symbol str)))
134+
135+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
136+
;;;;; Getters
137+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
138+
139+
(define (get-direct-name cont)
140+
(match cont
141+
; Nodes
142+
[(? string? n) (list n)]
143+
[(? symbol? n) (list n)]
144+
[(pair n props) (list n)]
145+
; Edges
146+
[(edge o t props) '()]
147+
[(to-many o ts props) '()]
148+
; Subgraph
149+
[(subgraph name cs) '()]
150+
; Attribute
151+
[(attr t props) '()]))
152+
153+
154+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
155+
;;;;; Pretty-Printing
156+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
157+
158+
; ppr-graph : Graph -> Seq
159+
(define (ppr-graph g)
160+
(match g
161+
[(graph n cs)
162+
(let ((header (+++ (str "digraph") (str n)))
163+
(body (vert (map ppr-cont cs))))
164+
(+++ header (curl-ind body)))]))
165+
166+
; ppr-cont : Content -> Seq
167+
(define (ppr-cont c)
168+
(match c
169+
; Nodes
170+
[(? string? n) (str n)]
171+
[(? symbol? n) (sym n)]
172+
[(pair n props) (end-semi (+++ (str n) (ppr-props props)))]
173+
; Edges
174+
[(edge o t props) (end-semi (ppr-to-target o t props))]
175+
[(to-many o ts props)
176+
(vert (map (lambda (x) (end-semi (ppr-to-target o x props))) ts))]
177+
; Subgraph
178+
[(subgraph name cs)
179+
(let ((header (+++ (str "subgraph") (str name)))
180+
(body (vert (map (compose end-semi ppr-cont) cs))))
181+
(+++ header (curl-ind body)))]
182+
; Attribute
183+
[(attr t props) (end-semi (+++ (str t) (ppr-props props)))]))
184+
185+
; Helper function for above
186+
(define (ppr-to-target o t props)
187+
(+++ (+-> (ppr-cont o) (ppr-cont t))
188+
(ppr-props props)))
189+
190+
; ppr-props : [Property] -> Seq
191+
(define (ppr-props ps)
192+
(match ps
193+
['() (nil)]
194+
[ps (sqr (comma-sep (map ppr-prop ps)))]))
195+
196+
; ppr-prop : Property -> Seq
197+
(define (ppr-prop p)
198+
(match p
199+
[(prop 'label val) (+= (sym 'label) (qt (sym val)))]
200+
[(prop par val) (+= (sym par) (sym val))]))

‎www/notes/knock/pretty-printer.rkt‎

Lines changed: 36 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -5,36 +5,49 @@
55
;;;;; Principal data structure for describing pretty-printed things
66
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
77

8+
; type Seq
9+
; | Str String
10+
; | Nil
11+
; | Newline
12+
; | Indent Seq
13+
; | Append Seq Seq
14+
815
(struct str (s) #:transparent)
916
(struct nil () #:transparent)
1017
(struct nl () #:transparent)
1118
(struct indent (s) #:transparent)
1219
(struct ++ (s1 s2) #:transparent)
1320

21+
;(list (cons (list (++ (++ (str "main")
22+
; (++ (str " ") (++ (str "->")
23+
; (++ (str " ") (str "print")))))
24+
; (++ (str " ") (nil))))
25+
; 2)
26+
; (cons (++ (nl) (str "}")) 0))
1427
; Efficiently converting that data structure into a string, avoiding the
1528
; n^2 append when dealing with left-nested appends
16-
(define (flatten col ss)
29+
(define (flatten-seq col ss)
1730
(match ss
1831
['() ""]
19-
[(cons (cons (indent s) i) rest) (flatten col `((,s . ,col) ,@rest))]
20-
[(cons (cons (nil) i) rest) (flatten col rest)]
32+
[(cons (cons (indent s) i) rest) (flatten-seq col `((,s . ,col) ,@rest))]
33+
[(cons (cons (nil) i) rest) (flatten-seq col rest)]
2134
[(cons (cons (str s) i) rest) (string-append s
22-
(flatten (+ (string-length s) i) rest))]
23-
[(cons (cons (++ s1 s2) i) rest) (flatten col `(,(cons s1 i)
35+
(flatten-seq (+ (string-length s) i) rest))]
36+
[(cons (cons (++ s1 s2) i) rest) (flatten-seq col `(,(cons s1 i)
2437
,(cons s2 i)
2538
,@rest))]
2639
[(cons (cons (nl) i) rest) (string-append
2740
"\n"
2841
(make-string i #\ )
29-
(flatten i rest))]))
42+
(flatten-seq i rest))]))
3043

3144
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3245
;;;;; Pretty-printing API
3346
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3447

3548
; Top-level pretty-print,
3649
(define (seq->string seq)
37-
(flatten 0 (list (cons seq 0))))
50+
(flatten-seq 0 (list (cons seq 0))))
3851

3952
;;;;; Appending Things
4053

@@ -46,8 +59,12 @@
4659
(define (+-> s1 s2)
4760
(+++ s1 (+++ (str "->") s2)))
4861

49-
; Append two things with an equals in between
62+
; Append two things with an equals in between (no space)
5063
(define (+= s1 s2)
64+
(++ s1 (++ (str "=") s2)))
65+
66+
; Append two things with an equals in between (space)
67+
(define (+=+ s1 s2)
5168
(+++ s1 (+++ (str "=") s2)))
5269

5370
;;;;; List of sequences
@@ -74,6 +91,9 @@
7491
(define (semi-sep seqs)
7592
(lst seqs sem))
7693

94+
(define (vert seqs)
95+
(lst seqs (nl)))
96+
7797
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7898
;;;;; Enclosing things
7999
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -94,6 +114,10 @@
94114
(define (par seq)
95115
(enc (str "(") (str ")") seq))
96116

117+
; Enclose the given sequence with double-quotes
118+
(define (qt seq)
119+
(enc (str "\"") (str "\"") seq))
120+
97121
;; Same as above but with an indented sequence
98122

99123
; This is ugly: TODO: Think of a better way
@@ -127,6 +151,10 @@
127151
;;;;; Miscelanious Characters or Symbols
128152
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
129153

154+
; When you have a symbol
155+
(define (sym s)
156+
(str (symbol->string s)))
157+
130158
; A set number of spaces
131159
(define (space i)
132160
(str (make-string i #\ )))

‎www/notes/knock/render-ast.rkt‎

Lines changed: 65 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,65 @@
1+
#lang racket
2+
(provide (all-defined-out))
3+
4+
(require "ast.rkt")
5+
(require "dot.rkt")
6+
7+
(define (render-prog p fn)
8+
(match p
9+
[(prog '() e)
10+
(match (render-expr e)
11+
[(cons _ res) (graph fn res)])]
12+
[(prog ds e)
13+
(match (render-expr e)
14+
[(cons _ res) (graph fn res)])]))
15+
16+
(define (render-fun f)
17+
(match f
18+
[(fundef name args body)
19+
(match (render-expr e)
20+
[(cons _ res) (subgraph name res)])]))
21+
22+
; render-expr : Expr -> (ID, [Content])
23+
(define (render-expr e)
24+
(let ((i (gensym)))
25+
(match e
26+
[(nil-e) (cons i (list (label "nil" i)))]
27+
[(int-e v) (cons i (list (label (~a v) i)))]
28+
[(bool-e b) (cons i (list (label (~a b) i)))]
29+
[(var-e v) (cons i (list (label (symbol->string v) i)))]
30+
[(char-e c) (cons i (list (label (~a c) i)))]
31+
[(fun-e f) (cons i (list (label (~a "fun " f) i)))]
32+
[(call-e f es) (cons i (render-subs i (~a "(call " f " ...)") es))]
33+
[(app-e f es) (cons i (render-subs i (~a "(" f " ...)") es))]
34+
[(prim-e p es) (cons i (render-subs i (~a "(" (symbol->string p) " ...)") es))]
35+
[(if-e e t f) (cons i (render-subs i "if" (list e t f)))]
36+
[(let-e bs b) (cons i (render-let i "let" bs b))])))
37+
38+
; On big programs this will be bad (it's n^2, I think)
39+
(define (render-subs pid str es)
40+
(let* ((subps (map render-expr es))
41+
(subs (append* (map cdr subps)))
42+
(parent (label str pid))
43+
(ids (map car subps)))
44+
`(,@subs
45+
,parent
46+
,(tm pid
47+
ids))))
48+
49+
(define (render-let pid str bs body)
50+
(let* ((bind (render-binding bs))
51+
(body (render-expr body))
52+
(parent (label str pid)))
53+
`(,@(cdr bind)
54+
,@(cdr body)
55+
,parent
56+
,(tm pid (list (car body) (car bind))))))
57+
58+
(define (render-binding bs)
59+
(match bs
60+
[(cons (binding v body) '())
61+
(let* ((i (gensym))
62+
(vn (label (symbol->string v) i))
63+
(bn (render-expr body))
64+
(cid (car bn)))
65+
(cons i `(,@(cdr bn) ,vn ,(color "deeppink2" (e i cid)))))]))

‎www/notes/knock/render-file.rkt‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
#lang racket
2+
(provide (all-defined-out))
3+
(require "compile.rkt" "syntax.rkt" "ast.rkt")
4+
(require "dot.rkt" "pretty-printer.rkt" "render-ast.rkt" "restricted.rkt")
5+
6+
;; String -> Void
7+
;; Compile contents of given file name,
8+
;; emit asm code on stdout
9+
(define (main fn)
10+
(with-input-from-file fn
11+
(λ ()
12+
(let ((c (read-line))
13+
(p (read)))
14+
(unless (expr? p) (error "syntax error" p))
15+
(display (seq->string (ppr-graph (render-prog (sexpr->prog p) "prog"))))))))

0 commit comments

Comments
 (0)