knock/dot.rkt

#lang racket

(provide (all-defined-out))

(require "pretty-printer.rkt")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; top-level graph

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; A graph is its name along with its list of contents

; graph : String [Content] -> Graph

(struct graph (name conts) #:transparent)

; A subgraph is its name along with its list of contents

; subgraph : String [Content] -> Graph

(struct subgraph (name conts) #:transparent)

; type Content =

;   | Node

;   | Edge

;   | ToMany    ; Edge from one shared parent to many targets

;   | Attribute

;   | Subgraph

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Graph internal structures

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Nodes

; type Node =

;   | String                <- Just a node

;   | Symbol                <- Just a node

;   | (String, [Property])  <- A node and some property

;   | SubG                  <- Subgraph (i.e. a set of nodes)

; An edge defines the origin node and the target node by name

; edge : Node Node [Property] -> Content

(struct edge (orig targ props) #:transparent)

; When one origin has many targets

; edge : Node [Node] [Property] -> Content

(struct to-many (orig targs props) #:transparent)

; An attribute described whether it applies to the edges or

; nodes and also has a list of properties

; attr : Symbol [Property] -> Content

(struct attr (type props) #:transparent)

; A property is a parameter and its value

(struct prop (par val) #:transparent)

; Pair

(struct pair (a b) #:transparent)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Constructors

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Make an edge between two nodes with no properties

; e : Node Node -> Content

(define (e n1 n2)

(edge n1 n2 '()))

; Make edges between a list of nodes

; es [Node] -> [Content]

(define (es ns)

(match ns

[(cons n1 (cons n2 '())) (cons (edge n1 n2 '()) '())]

[(cons n1 (cons n2 ns))  (cons (edge n1 n2 '()) (es (cons n2 ns)))]

[_  (error "There must be at least 2 nodes given to es")]))

(define (tm n1 ns)

(to-many n1 ns '()))

; Set a node to a specific shape

; There are many, but we'll start with:

;  * box

;  * oval

;  * circle

;  * diamond

;  * rect

;

; shape : Symbol Node -> Node

(define (shape sh node)

(match node

[(? string? n)  (pair n (list (prop 'shape sh)))]

[(? symbol? n)  (pair (symbol->string n) (list (prop 'shape sh)))]

[(pair n props) (pair n (cons (prop 'shape sh) props))]))

; Attach meta-data to content, the parameter must be passed

; as a label

; attach : Symbol Symbol Content -> Content

(define (attach param st cont)

(match cont

; Nodes

[(? string? n)  (pair n (list (prop param st)))]

[(? symbol? n)  (pair (symbol->string n) (list (prop param st)))]

[(pair n props) (pair n (cons (prop param st) props))]

; Edges

[(edge o t props)    (edge o t (cons (prop param st) props))]

[(to-many o t props) (to-many o t (cons (prop param st) props))]

; Attribute

[(attr t props) (attr t (cons (prop param st) props))]))

; Color some Content

; Known colors:

;  * red

;  * blue

;  * black

;  * darkgreen

;  * brown

;  * deeppink2

(define (color val cont)

(attach 'color (string->symbol val) cont))

; Set the style of some contents

; There are many, but we'll start with:

;  * dashed

;  * dotted

;  * bold

;

; style : Symbol Content -> Content

(define (style st cont)

(attach 'style st cont))

; Attach a label to Content

(define (label lab cont)

(attach 'label (string->symbol lab) cont))

; Attach a label to Content

(define (label-str lab str)

(attach 'label (string->symbol lab) (string->symbol str)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Getters

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (get-direct-name cont)

(match cont

; Nodes

[(? string? n)    (list n)]

[(? symbol? n)    (list n)]

[(pair n props)   (list n)]

; Edges

[(edge o t props) '()]

[(to-many o ts props) '()]

; Subgraph

[(subgraph name cs) '()]

; Attribute

[(attr t props)   '()]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Pretty-Printing

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; ppr-graph : Graph -> Seq

(define (ppr-graph g)

(match g

[(graph n cs)

(let ((header (+++ (str "digraph") (str n)))

(body   (vert (map ppr-cont cs))))

(+++ header (curl-ind body)))]))

; ppr-cont : Content -> Seq

(define (ppr-cont c)

(match c

; Nodes

[(? string? n)    (str n)]

[(? symbol? n)    (sym n)]

[(pair n props)   (end-semi (+++ (str n) (ppr-props props)))]

; Edges

[(edge o t props) (end-semi (ppr-to-target o t props))]

[(to-many o ts props)

(vert (map (lambda (x) (end-semi (ppr-to-target o x props))) ts))]

; Subgraph

[(subgraph name cs)

(let ((header (+++ (str "subgraph") (str name)))

(body   (vert (map (compose end-semi ppr-cont) cs))))

(+++ header (curl-ind body)))]

; Attribute

[(attr t props)   (end-semi (+++ (str t) (ppr-props props)))]))

; Helper function for above

(define (ppr-to-target o t props)

(+++ (+-> (ppr-cont o) (ppr-cont t))

(ppr-props props)))

; ppr-props : [Property] -> Seq

(define (ppr-props ps)

(match ps

['() (nil)]

[ps (sqr (comma-sep (map ppr-prop ps)))]))

; ppr-prop : Property -> Seq

(define (ppr-prop p)

(match p

[(prop 'label val) (+= (sym 'label) (qt (sym val)))]

[(prop par val) (+= (sym par) (sym val))]))

knock/render-ast.rkt

#lang racket

(provide (all-defined-out))

(require "ast.rkt")

(require "dot.rkt")

(define (render-prog p fn)

(match p

[(prog '() e)

(match (render-expr e)

[(cons _ res) (graph fn res)])]

[(prog ds e)

(match (render-expr e)

[(cons _ res) (graph fn res)])]))

(define (render-fun f)

(match f

[(fundef name args body)

(match (render-expr e)

[(cons _ res) (subgraph name res)])]))

; render-expr : Expr -> (ID, [Content])

(define (render-expr e)

(let ((i (gensym)))

(match e

[(nil-e)       (cons i (list (label "nil" i)))]

[(int-e v)     (cons i (list (label (~a v) i)))]

[(bool-e b)    (cons i (list (label (~a b) i)))]

[(var-e v)     (cons i (list (label (symbol->string v) i)))]

[(char-e c)    (cons i (list (label (~a c) i)))]

[(fun-e f)     (cons i (list (label (~a "fun " f) i)))]

[(call-e f es)

(cons i (let ((l (label (~a "(call " (fname f) " ...)") i)))

(render-subs i l es)))]

[(app-e f es)

(cons i (let ((l (label (~a "(" f " ...)") i)))

(render-subs i l es)))]

[(prim-e p es)

(cons i (let* ((l (label (~a "(" (symbol->string p) " ...)") i))

(l2 (color "red" l)))

(render-subs i l2 es)))]

[(if-e e t f)

(cons i (let ((l (label "if" i)))

(render-subs i l (list e t f))))]

[(let-e bs b)  (cons i (render-let i "let" bs b))])))

; On big programs this will be bad (it's n^2, I think)

(define (render-subs pid parent es)

(let* ((subps (map render-expr es))

(subs  (append* (map cdr subps)))

(ids (map car subps)))

`(,@subs

,parent

,(tm pid

ids))))

(define (render-let pid str bs body)

(let* ((bind (render-binding bs))

(body (render-expr body))

(parent (label str pid)))

`(,@(cdr bind)

,@(cdr body)

,parent

,(tm pid (list (car body) (car bind))))))

(define (render-binding bs)

(match bs

[(cons (binding v body) '())

(let* ((i (gensym))

(vn (label (symbol->string v) i))

(bn (render-expr body))

(cid (car bn)))

(cons i `(,@(cdr bn) ,vn ,(color "deeppink2" (e i cid)))))]))

(define (fname f)

(match f

[(fun-e f) f]

[_         f]))

knock/pretty-printer.rkt

#lang racket

(provide (all-defined-out))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Principal data structure for describing pretty-printed things

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; type Seq

; | Str String

; | Nil

; | Newline

; | Indent Seq

; | Append Seq Seq

(struct str    (s)     #:transparent)

(struct nil    ()      #:transparent)

(struct nl     ()      #:transparent)

(struct indent (s)     #:transparent)

(struct ++     (s1 s2) #:transparent)

;(list (cons (list (++ (++ (str "main")

;                      (++ (str " ") (++ (str "->")

;                      (++ (str " ") (str "print")))))

;                      (++ (str " ") (nil))))

;             2)

;      (cons (++ (nl) (str "}")) 0))

; Efficiently converting that data structure into a string, avoiding the

; n^2 append when dealing with left-nested appends

(define (flatten-seq col ss)

(match ss

['() ""]

[(cons (cons (indent s) i) rest) (flatten-seq col `((,s . ,col) ,@rest))]

[(cons (cons (nil) i)      rest) (flatten-seq col rest)]

[(cons (cons (str s) i)    rest) (string-append s

(flatten-seq (+ (string-length s) i) rest))]

[(cons (cons (++ s1 s2) i) rest) (flatten-seq col `(,(cons s1 i)

,(cons s2 i)

,@rest))]

[(cons (cons (nl) i)       rest) (string-append

"\n"

(make-string i #\ )

(flatten-seq i rest))]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Pretty-printing API

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Top-level pretty-print,

(define (seq->string seq)

(flatten-seq 0 (list (cons seq 0))))

;;;;; Appending Things

; Append two things with a space in between

(define (+++ s1 s2)

(++ s1 (++ ss s2)))

; Append two things with an arrow in between

(define (+-> s1 s2)

(+++ s1 (+++ (str "->") s2)))

; Append two things with an equals in between (no space)

(define (+= s1 s2)

(++ s1 (++ (str "=") s2)))

; Append two things with an equals in between (space)

(define (+=+ s1 s2)

(+++ s1 (+++ (str "=") s2)))

;;;;; List of sequences

;;;;;   * no separation

;;;;;   * space separated

;;;;;   * Comma separated

;;;;;   * semi-colon separated

(define (lst seqs sep)

(match seqs

['() (nil)]

[(cons s '()) s]

[(cons s ss)  (++ s (++ sep (lst ss sep)))]))

(define (no-sep seqs)

(lst seqs (nil)))

(define (sp-sep seqs)

(lst seqs ss))

(define (comma-sep seqs)

(lst seqs com))

(define (semi-sep seqs)

(lst seqs sem))

(define (vert seqs)

(lst seqs (nl)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Enclosing things

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Enclose a sequence with the given open and close sequences

(define (enc open close seq)

(+++ open (+++ seq close)))

; Enclose the given sequence with curly braces

(define (curly seq)

(enc (str "{") (str "}") seq))

; Enclose the given sequence with square braces

(define (sqr seq)

(enc (str "[") (str "]") seq))

; Enclose the given sequence with parentheses

(define (par seq)

(enc (str "(") (str ")") seq))

; Enclose the given sequence with double-quotes

(define (qt seq)

(enc (str "\"") (str "\"") seq))

;; Same as above but with an indented sequence

; This is ugly: TODO: Think of a better way

(define (enc-ind open close seq)

(++ open (++ (nl)

(++ (space 2)

(++ (indent seq)

(++ (nl) close))))))

; Enclose and indent with curly braces

(define (curl-ind seq)

(enc-ind (str "{") (str "}") seq))

; Enclose and indent with square braces

(define (sqr-ind seq)

(enc-ind (str "[") (str "]") seq))

; Enclose and indent with parantheses

(define (par-ind seq)

(enc-ind (str "(") (str ")") seq))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; End line with various things

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (end-semi seq)

(++ seq (++ sem (nl))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Miscelanious Characters or Symbols

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; When you have a symbol

(define (sym s)

(str (symbol->string s)))

; A set number of spaces

(define (space i)

(str (make-string i #\ )))

; A single space

(define ss (str " "))  ; single space

;;; Comma, semi-colons, and colons

(define com (str ","))

(define sem (str ";"))

(define col (str ":"))