/load/ppr.arc

  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
 24	       (print cadr.x))
 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)))