http://github.com/alimoeeny/arc
Unknown | 180 lines | 160 code | 20 blank | 0 comment | 0 complexity | 4430c1f943da74492545d30514a88d2b MD5 | raw file
```  1(= pprsyms* (fill-table (table)
2			'(quote "'"
3			  quasiquote "`"
4			  unquote ","
5			  unquote-splicing ",@")))
6
7(def sp ((o n 1))
8  " Print a number of spaces. "
9  (repeat n (pr " ")))
10
11(def print-spaced (xs)
12  " Print the expressions in the list separated by spaces. "
13  (when xs
14    (print car.xs)
15    (each x cdr.xs (sp) print.x)))
16
17(def print (x)
18  " Print an expression on one line, replacing quote, unquote,
19    quasiquote, unquote-splicing, and make-br-fn with their respective symbols. "
20  (do (aif (or atom.x dotted.x)
21	     write.x
22	   (pprsyms* car.x)
23	     (do pr.it
25	   (is car.x 'make-br-fn)
26	     (do (pr "[") (print-spaced cadr.x) (pr "]"))
27	   (do (pr "(") print-spaced.x (pr ")")))
28      x))
29
30(= oneline* 45)
31
32(def len (x (o c 0))
33  " Measures the length of a string, vector, table, list or dotted list. "
34  (if (isa x 'string) (\$.string-length x)
35      (isa x 'vec) (\$.vector-length x)
36      (isa x 'table) (\$.hash-table-count x)
37      (and atom.x x) (+ c 1)
38      acons.x (len cdr.x (+ c 1))
39      c))
40
41(mac indent (col . body)
42  `(do (unless noindent sp.col)
43       ,@body))
44
45(mac ppr-sub body
46  `(indent col
47      (let whole (tostring print.x)
48	(if (< len.whole oneline*)
49	    (do pr.whole nil)
50	    (do ,@body t)))))
51
52(def indent-pairs (xs (o col 0))
53  (let l (apply max 0 (map len:tostring:print:car (keep cdr pair.xs)))
54    (on x pair.xs
55        (if (~is index 0)
56            (do (prn)
57                (sp col)))
58        (let str (tostring:print car.x)
59          (if cdr.x
60              (do pr.str
61                  (sp:- l len.str -1)
62                  (ppr-main cadr.x (+ col 1 l) t))
63              ; lone tail expression
64              (do (sp (+ l 1))
65                  (ppr-main car.x (+ col (+ l 1)) t)))))))
66
67(def indent-block (xs (o col 0))
68  (each x xs (prn) (ppr-main x col)))
69
70(def indent-mac (xs (o args 0) (o col 0))
71  (print-spaced (firstn args xs))
72  (indent-block (nthcdr args xs) (+ col 2)))
73
74(def indent-basic (xs l (o col 0))
75  (if (all [or atom._ (and (is car._ 'quote) (atom cadr._))]
76	   xs)
77      print-spaced.xs
78      (do (ppr-main car.xs (+ col 2 l) t)
79	  (indent-block cdr.xs (+ col 2 l)))))
80
81(def indent-wave (xs (o col 0))
82  (do (ppr-main car.xs col t)
83      (on x cdr.xs
84	  (prn)
85	  (ppr-main x (+ col (* 2 (mod (+ index 1) 2)))))))
86
87(= ifline* 20)
88
89(def indent-if (l)
90  (fn (xs (o col 0))
91      (if (< len.xs 4)
92	    (on x xs
93		(if (~is index 0) (prn))
94		(ppr-main x (+ col 2 l) (is index 0)))
95	  (all [< (len:tostring print._) ifline*]
96	       pair.xs)
97	    (indent-pairs xs (+ col 2 l))
98	  (indent-wave xs (+ col 2 l)))))
99
100(def indent-with (l)
101  (fn (xs (o col 0))
102      (pr "(")
103      (indent-pairs car.xs (+ col 3 l))
104      (pr ")")
105      (indent-block cdr.xs (+ col 3))))
106
107(def indent-def (xs (o col 0))
108  (print-spaced (firstn 2 xs))
109  (if (isa xs.2 'string)
110      (do (prn)
111	  (sp (+ col 2))
112	  (pr #\" xs.2 #\")
113	  (indent-block (nthcdr 3 xs) (+ col 2)))
114      (indent-block (nthcdr 2 xs) (+ col 2))))
115
116(def indent-case (n)
117  (fn (xs (o col 0))
118      (print-spaced:firstn n xs)
119      (prn)
120      (sp (+ col 2))
121      (indent-pairs (nthcdr n xs) (+ col 2))))
122
123(= indent-rules*
124   (fill-table (table)
125     `(if      ,(indent-if 2)
126       aif     ,(indent-if 3)
127       with    ,(indent-with 4)
128       withs   ,(indent-with 5)
129       def     ,indent-def
130       mac     ,indent-def
131       do      ,[indent-basic _ 2 _2]
132       and     ,[indent-basic _ 3 _2]
133       or      ,[indent-basic _ 2 _2]
134       nor     ,[indent-basic _ 3 _2]
135       case    ,(indent-case 1)
136       caselet ,(indent-case 2)
137       fn      ,[indent-mac _ 1 _2])))
138
139(def ppr-main (x (o col 0) (o noindent nil))
140  " Recursive main body of the ppr function. "
141  (aif (or atom.x dotted.x)		;just print the expression if it's an atom or dotted list
142         (indent col
143	   print.x
144	   nil)
145       (is car.x 'make-br-fn)		;if the expression is a br-fn, print the brackets and then the contents
146         (ppr-sub
147	   (pr "[")
148	   (ppr-main cadr.x (+ col 1) t)
149	   (pr "]"))
150       (pprsyms* car.x)
151         (ppr-sub
152	   pr.it
153	   (ppr-main cadr.x (+ col len.it) t))
154       (ppr-sub
155	 (pr "(")
156	 (withs (proc car.x
157		 args sig.proc
158                 n    len.args
159		 str  (tostring:print proc)
160		 l    len.str
161		 xs   cdr.x)
162	   (if (isa proc 'cons)
163	       (do (ppr-main proc (+ col 1) t)
164		   (indent-block xs (+ col 1)))
165	       (do pr.str
166		   (when xs
167		     (sp)
168		     (aif indent-rules*.proc
169			    (it xs col)
170			  (and (isa proc 'sym) (bound proc) (isa (eval proc) 'mac))
171			    (if (or dotted.args (and args (~acons args)))
172				(indent-mac xs (- len.args 1) col)
173				(indent-mac xs 0 col))
174			  (indent-basic xs l col)))))
175	   (pr ")")))))
176
177(def ppr l
178  " Pretty print. This function displays arc code with proper
179    indenting and representation of syntax. "
180  (each x l (ppr-main x) (prn)))```