176 lines
5.1 KiB
Racket
176 lines
5.1 KiB
Racket
#lang typed/racket
|
||
(require "ast.rkt")
|
||
(require "semantics.rkt")
|
||
|
||
(define-type IndentLevel Integer)
|
||
|
||
(define-type ISeq
|
||
(∪ Null
|
||
String
|
||
(List 'Hang IndentLevel ISeq)
|
||
'Newline
|
||
(List '++ ISeq ISeq)
|
||
(List 'Indent IndentLevel ISeq)))
|
||
|
||
(define-syntax iseq-append-with-sep
|
||
(syntax-rules ()
|
||
[(iseq-append-with-sep _) '()]
|
||
[(iseq-append-with-sep _ a) a]
|
||
[(iseq-append-with-sep sep a b c ...)
|
||
(iseq-append a sep (iseq-append-with-sep sep b c ...) )]))
|
||
|
||
(: seq (-> ISeq ISeq ISeq))
|
||
(define (seq a b)
|
||
(match (list a b)
|
||
[`(() ,b) b]
|
||
[`(,a ()) a]
|
||
[_ (list '++ a b)]))
|
||
|
||
(define-syntax iseq-append
|
||
(syntax-rules ()
|
||
[(iseq-append a b) (seq a b)]
|
||
[(iseq-append a b c ...) (seq a (iseq-append b c ...))]))
|
||
|
||
(: ppr-list (All (A) (-> (-> A ISeq) ISeq (Listof A) ISeq)))
|
||
(define (ppr-list f sep xs)
|
||
(match xs
|
||
['() '()]
|
||
[(list x) (f x)]
|
||
[(list x y xs ...)
|
||
(iseq-append (f x) sep (ppr-list f sep (cons y xs)))]))
|
||
|
||
(: ppr-alt (-> CoreAlt ISeq))
|
||
(define (ppr-alt a)
|
||
(match a
|
||
[(list con xs body)
|
||
(iseq-append-with-sep
|
||
" "
|
||
(iseq-append
|
||
"<"
|
||
(number->string con)
|
||
">")
|
||
(ppr-list symbol->string " " xs)
|
||
"->"
|
||
(ppr-expr body))]))
|
||
|
||
(: ppr-bind (-> CoreBind ISeq))
|
||
(define (ppr-bind a)
|
||
(match a
|
||
[(list x a)
|
||
(iseq-append-with-sep " " (symbol->string x) "=" (ppr-expr a))]))
|
||
|
||
(: ppr-binds (-> CoreBinds ISeq))
|
||
(define (ppr-binds a)
|
||
(ppr-list ppr-bind (iseq-append ";" 'Newline) a))
|
||
|
||
(: ppr-alts (-> CoreAlts ISeq))
|
||
(define (ppr-alts x) (ppr-list ppr-alt (iseq-append ";" 'Newline) x))
|
||
|
||
(: ppr-case (-> CoreExpr CoreAlts ISeq))
|
||
(define (ppr-case e alts)
|
||
(iseq-append
|
||
(iseq-append-with-sep
|
||
" "
|
||
"case"
|
||
(ppr-expr e)
|
||
"of")
|
||
(list 'Hang -2
|
||
(iseq-append 'Newline (ppr-alts alts)))))
|
||
|
||
(: ppr-lets (-> Let CoreBinds CoreExpr ISeq))
|
||
(define (ppr-lets lt binds e)
|
||
(list 'Hang 0
|
||
(iseq-append
|
||
(symbol->string lt)
|
||
" "
|
||
(list 'Hang 0 (ppr-binds binds))
|
||
(iseq-append 'Newline "in " (ppr-expr e)))))
|
||
|
||
(: ppr-expr (-> CoreExpr ISeq))
|
||
(define (ppr-expr a)
|
||
(match a
|
||
[`(,f ,x) (iseq-append (ppr-expr f) " " (ppr-aexpr x))]
|
||
[(? integer? n) (number->string n)]
|
||
[(? symbol? x) (symbol->string x)]
|
||
[`(case ,e ,alts) (ppr-case e alts)]
|
||
[`(let ,binds ,e) (ppr-lets 'let binds e)]
|
||
[`(letrec ,binds ,e) (ppr-lets 'letrec binds e)]))
|
||
|
||
(: ppr-aexpr (-> CoreExpr ISeq))
|
||
(define (ppr-aexpr a)
|
||
(if (or (integer? a) (symbol? a))
|
||
(ppr-expr a)
|
||
(iseq-append "(" (ppr-expr a) ")")))
|
||
|
||
(: ppr-addr (-> Addr String))
|
||
(define (ppr-addr a)
|
||
(number->string a))
|
||
|
||
(: ppr-fwaddr (-> Addr ISeq))
|
||
(define (ppr-fwaddr a)
|
||
(let ([s (ppr-addr a)])
|
||
(iseq-append (make-string (- 4 (string-length s)) #\ ) s)))
|
||
|
||
(: ppr-node (-> Node ISeq))
|
||
(define (ppr-node a)
|
||
(cond
|
||
[(integer-node? a)
|
||
(iseq-append "NNum " (number->string a))]
|
||
[(ap-node? a)
|
||
(let ([fun (ap-fun a)]
|
||
[arg (ap-arg a)])
|
||
(iseq-append "NAp " (ppr-addr fun) " " (ppr-addr arg)))]
|
||
[(sc-node? a) (iseq-append "NSupercomb " (symbol->string (caadr a)))]
|
||
[(indirect-node? a) (iseq-append "Indirect " (ppr-addr (indirect-addr a)))]
|
||
[else (error "Impossible: Undefined node encountered")]))
|
||
|
||
(: ppr-stack-node (-> Heap Node ISeq))
|
||
(define (ppr-stack-node heap node)
|
||
(if (and (pair? node) (not (symbol? (car node))))
|
||
(let ([fun : Addr (first node)]
|
||
[arg : Addr (second node)])
|
||
(iseq-append-with-sep
|
||
" " "NAp" (ppr-fwaddr fun) (ppr-fwaddr arg) "(" (ppr-node (lookup-node heap arg)) ")"))
|
||
(ppr-node node)))
|
||
|
||
(: ppr-stack (-> Heap Stack ISeq))
|
||
(define (ppr-stack heap stack)
|
||
(let ([ppr-stack-item
|
||
: (-> Addr ISeq)
|
||
(λ (addr) (iseq-append (ppr-fwaddr addr) ": " (ppr-stack-node heap (lookup-node heap addr))))])
|
||
(iseq-append "Stk [" (list 'Hang 0 (ppr-list ppr-stack-item 'Newline stack)) "]")))
|
||
|
||
(: ppr-state (-> State ISeq))
|
||
(define (ppr-state st)
|
||
(let ([stack (State-stack st)]
|
||
[heap (State-heap st)])
|
||
(iseq-append (ppr-stack heap stack) 'Newline)))
|
||
|
||
|
||
(: iseq->string (-> IndentLevel ISeq String))
|
||
(define (iseq->string l a)
|
||
(let ([s (open-output-string)])
|
||
(port-count-lines! s)
|
||
(letrec ([go : (-> IndentLevel ISeq Void)
|
||
(λ (l i)
|
||
(match i
|
||
['() (void)]
|
||
[`(++ ,i0 ,i1) (begin
|
||
(go l i0)
|
||
(go l i1))]
|
||
[`(Indent ,l0 ,i) (go (max (+ l l0) 0) i)]
|
||
[`(Hang ,l0 ,i)
|
||
(let-values ([(linum col-pos pos) (port-next-location s)])
|
||
(if (not (false? col-pos))
|
||
(go (max (+ col-pos l0) 0) i)
|
||
(error "impossible: line counting not enabled")))]
|
||
['Newline (display
|
||
(string-append
|
||
"\n"
|
||
(make-string l #\space))
|
||
s)]
|
||
[(? string?) (display i s)]))])
|
||
(go l a)
|
||
(get-output-string s))))
|
||
|
||
(provide (all-defined-out))
|