source: project/release/3/strictly-pretty/trunk/strictly-pretty.scm @ 12060

Last change on this file since 12060 was 12060, checked in by Ivan Raikov, 13 years ago

Switched to using matchable.

File size: 7.8 KB
Line 
1
2;;
3;; _Strictly Pretty_
4;; Christian Lindig
5;;
6;; Adapted for Chicken Scheme by Ivan Raikov.
7;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22;;
23
24(require-extension syntax-case)
25(require-extension matchable)
26(require-extension datatype)
27(require-extension srfi-1)
28
29(define-extension strictly-pretty)
30
31(declare (export doc? doc:cons doc:empty doc:text doc:nest doc:break
32                 doc:break-with doc:group doc:concat 
33                 doc:binop doc:ifthen doc:list doc:block doc:letblk
34                 doc:space doc:comma doc:connect
35                 doc:display doc:format sdoc? sdoc->string))
36
37
38(define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))
39
40
41(define-datatype doc doc?
42  (DocNil)
43  (DocCons   (car doc?) (cdr doc?))
44  (DocText   (text string?))
45  (DocNest   (level integer?) (body doc?))
46  (DocBreak  (sep string?))
47  (DocGroup  (group doc?)))
48
49(define-datatype sdoc sdoc?
50  (SNil)
51  (SText (text string?) (next sdoc?))
52  (SLine (indent integer?) (body sdoc?)))
53
54(define-datatype mode mode?
55  (Flat)
56  (Break))
57
58
59(define-record-printer (mode x out)
60  (cases mode x
61         (Flat () (fprintf out "#(mode Flat)"))
62         (Break () (fprintf out "#(mode Break)"))))
63
64(define-record-printer (sdoc x out)
65  (cases sdoc x
66         (SNil ()     (fprintf out "#(SNil)"))
67         (SText (t n) (fprintf out "#(SText ~S ~A)" t n))
68         (SLine (i d) (fprintf out "#(SLine (~A, ~A))" i d))))
69
70(define-record-printer (doc x out)
71  (cases doc x
72         (DocNil ()     (fprintf out "#(DocNil)"))
73         (DocCons (x y) (fprintf out "#(DocCons ~A ~A)" x y))
74         (DocText (s)   (fprintf out "#(DocText ~A)" s))
75         (DocNest (i d) (fprintf out "#(DocNest (~A, ~A))" i d))
76         (DocBreak (s)  (fprintf out  "#(DocBreak ~S)" s))
77         (DocGroup (g)  (fprintf out  "#(DocGroup ~A)" g))))
78
79
80
81(define (doc:cons x y)  (DocCons x y))
82(define (doc:empty)     (DocNil))
83(define (doc:text s)    (DocText s))
84(define (doc:nest i x)  (DocNest i x))
85(define (doc:break)     (DocBreak " "))
86(define (doc:break-with s)  (DocBreak s)) 
87(define (doc:group x)   (DocGroup x))
88
89(define (doc:connect x y)
90  (cases doc x
91         (DocNil ()   y)
92         (else   (cases doc y 
93                        (DocNil () x)
94                        (else (doc:cons x (doc:cons (doc:break) y)))))))
95
96(define (doc:connect-with s x y)
97  (cases doc x
98         (DocNil ()   y)
99         (else   (cases doc y 
100                        (DocNil () x)
101                        (else (doc:cons x (doc:cons (doc:break-with s) y)))))))
102
103(define (doc:concat lst)
104  (match lst
105         (()     (doc:empty))
106         (( x )  (doc:group x))
107         (( x . rest)  (cases doc x 
108                              (DocNil ()  (doc:concat rest))
109                              (else       (doc:cons x (doc:concat rest)))))
110         (else (error "doc:concat: invalid  doc list"))))
111
112(define (doc:fits w x)
113  (if (< w 0) #f
114      (match x
115             (()  #t)
116             ((( i m x ) . rest)  (cases doc x
117                                       (DocNil   ()     (doc:fits w rest))
118                                       (DocCons  (x y)  (doc:fits w (cons (list i m x) (cons (list i m y) rest))))
119                                       (DocNest  (j x)  (doc:fits w (cons (list (+ i j) m x) rest)))
120                                       (DocText  (s)    (doc:fits (- w (string-length s)) rest))
121                                       (DocGroup (x)    (doc:fits w (cons (list i (Flat) x) rest)))
122                                       (DocBreak (s)    (cases mode m 
123                                                               (Flat ()  (doc:fits (- w (string-length s)) rest))
124                                                               (Break () #t)))))
125             (else (error "doc:fits: invalid doc list")))))
126
127(define (format1 w k x)
128  (match x 
129         (()   (SNil))
130         ((( i m x ) . rest)  (cases doc x
131                                     (DocNil ()      (format1 w k rest))
132                                     (DocCons (x y)  (format1 w k (cons (list i m x) (cons (list i m y) rest))))
133                                     (DocNest (j x)  (format1 w k (cons (list (+ i j) m x) rest)))
134                                     (DocText (s)    (SText s (format1 w (+ k (string-length s)) rest)))
135                                     (DocGroup (x)   (if (doc:fits (- w k) (cons (list i (Flat) x) rest))
136                                                         (format1 w k (cons (list i (Flat) x) rest))
137                                                         (format1 w k (cons (list i (Break) x) rest))))
138                                     (DocBreak (s)   (cases mode m
139                                                            (Flat ()  (SText s (format1 w (+ k (string-length s)) rest)))
140                                                            (Break () (SText s (SLine i (format1 w i rest))))))))
141         (else (error "doc:format1: invalid doc list"))))
142         
143(define (doc:format w x) (format1 w 0 (list (list 0 (Flat) (DocGroup x)))))
144
145
146(define (sdoc->string x)
147  (let loop ((port (open-output-string)) (x x))
148    (cases sdoc x
149           (SNil ()      (get-output-string port))
150           (SText (s d)  (begin
151                           (display s port) 
152                           (loop port d)))
153           (SLine (i d)  (let ((prefix (make-string i #\space)))
154                           (display "\n" port)
155                           (display prefix port)
156                           (loop port d))))))
157
158
159(define (PNil) (void))
160(define (PText str next) 
161  (display str)
162  (next))
163(define (PLine indent body)
164  (display (spaces indent))
165  (body))
166 
167(define (doc:display1 w k x)
168  (match x 
169         (()   (PNil))
170         ((( i m x ) . rest) 
171          (cases doc x
172                 (DocNil ()      (doc:display1 w k rest))
173                 (DocCons (x y)  (doc:display1 w k (cons (list i m x) (cons (list i m y) rest))))
174                 (DocNest (j x)  (doc:display1 w k (cons (list (+ i j) m x) rest)))
175                 (DocText (s)    (PText s (lambda () (doc:display1 w (+ k (string-length s)) rest))))
176                 (DocGroup (x)   (if (doc:fits (- w k) (cons (list i (Flat) x) rest))
177                                     (doc:display1 w k (cons (list i (Flat) x) rest))
178                                     (doc:display1 w k (cons (list i (Break) x) rest))))
179                 (DocBreak (s)   (cases mode m
180                                        (Flat ()  (PText s (lambda () (doc:display1 w (+ k (string-length s)) rest))))
181                                        (Break () (PText s (lambda () (PLine i (doc:display1 w i rest)))))))))
182         (else (error "doc:display1: invalid doc list " x))))
183         
184(define (doc:display w x) (doc:display1 w 0 (list (list 0 (Flat) (DocGroup x)))))
185
186
187(define (doc:binop indent)
188  (lambda (left oper right)
189    (doc:group (doc:nest indent (doc:connect (doc:group (doc:connect left oper)) right)))))
190
191(define (doc:list indent elem->doc sep)
192  (define (ll ax lst)
193    (match lst
194           (()  (reverse ax))
195           ((x) (reverse (cons (doc:group (doc:nest indent (elem->doc x))) ax)))
196           ((x . rest)  (ll (cons (sep) (cons (doc:group (doc:nest indent (elem->doc x))) ax)) rest))))
197       
198  (lambda (lst)
199    (doc:group (doc:concat (ll (list) lst)))))
200
201(define (doc:ifthen indent i t e)
202  (lambda (c e1 e2)
203    (doc:group 
204     (doc:nest indent 
205               (doc:connect (doc:connect i c)
206                            (doc:connect (doc:group (doc:nest indent (doc:connect t e1)))
207                                         (doc:group (doc:nest indent (doc:connect e e2)))))))))
208   
209(define (doc:block indent open close)
210  (lambda (b)
211    (doc:group (doc:cons open (doc:cons (doc:nest indent b) close)))))
212
213(define (doc:letblk indent l i e)
214  (lambda (e1 e2)
215    (doc:group (doc:connect (doc:nest indent (doc:connect l (doc:group e1)))
216                            (doc:connect (doc:nest indent (doc:connect i (doc:group e2))) e)))))
217       
218
219(define (doc:space)  (doc:text " "))
220                     
221(define (doc:comma)  (doc:break-with ", "))
222                     
223; Examples:
224#|
225(define cond1 ((doc:binop 2) (doc:text "a") (doc:text "==") (doc:text "b")))
226(define e1    ((doc:binop 2) (doc:text "a") (doc:text "<<") (doc:text "2")))
227(define e2    ((doc:binop 2) (doc:text "c") (doc:text "+") (doc:text "d")))
228
229(define doc1 ((doc:ifthen 2 (doc:text "if") (doc:text "then") (doc:text "else"))
230              cond1 e1 e2))
231
232(define doc2 ((doc:block 2 (doc:text "(") (doc:text ")")) doc1))
233
234(define doc3 ((doc:list 2 (lambda (x) x) doc:break) (list e1 e2)))
235(define doc4 ((doc:letblk 2 (doc:text "program") (doc:text "in") (doc:text "end"))
236              doc3 doc1))
237
238(print (sdoc->string (doc:format 32 doc4)))
239
240(print (sdoc->string (doc:format 10 doc4)))
241
242|#
Note: See TracBrowser for help on using the repository browser.