JSLisp/pprint.lisp at master · 6502/JSLisp · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
(defvar *print-width* 70)

(defun pprint (obj)
  "Tries to format reasonably an object that contains JsLisp source code.
   This function is useful mostly for displaying the result of macro \
   expansion. See {{macroexpand-1}}[[
   (pprint '(labels((fact(x)(if(< x 2)1(*
            x(fact(1- x))))))(fact 10)))
   ;; produces as output
   (labels ((fact (x)
              (if (< x 2)
                  1
                  (* x (fact (1- x))))))
     (fact 10))
   ]]"
  (let ((result "")
        (col 0)
        (row 0)
        (indent (list 0)))
    (labels ((newline ()
               (incf result "\n")
               (repeat (last indent)
                 (incf result " "))
               (incf row)
               (setf col (last indent)))
             (output (str)
               (when (and (= (first str) "\n")
                          (> (length str) 1))
                 (newline)
                 (setf str (slice str 1)))
               (case str
                 ("\n"
                    (newline))
                 ("("
                    (incf result str)
                    (incf col)
                    (push col indent))
                 (")"
                    (incf result str)
                    (incf col)
                    (pop indent))
                 (otherwise
                    (when (and (> col (last indent))
                               (> (+ col (length str)) *print-width*))
                      (newline))
                    (incf result str)
                    (incf col (length str)))))
             (sname (x)
               (if (symbol? x) (symbol-name x)))
             (sep (ppx px x i)
               (let ((nx (sname (first x)))
                     (npx (sname (first px)))
                     (nppx (sname (first ppx))))
                 (cond
                   ((and (list? (first x))
                         (/= '\. (first (first x)))) "\n")
                   ((= nx "progn") "\n ")
                   ((= nx "defproperty") (if (>= i 2) "\n " " "))
                   ((= nx "with-canvas") (if (>= i 1) "\n " " "))
                   ((= nx "do") (cond
                                        ((= i 0) " ")
                                        ((= i 1) "\n   ")
                                        (true "\n ")))
                   ((= nx "cond") "\n ")
                   ((= nx "labels") (if (>= i 1) "\n " " "))
                   ((= nx "macrolet") (if (>= i 1) "\n " " "))
                   ((= nx "symbol-macrolet") (if (>= i 1) "\n " " "))
                   ((= nx "case") (if (>= i 1) "\n " " "))
                   ((= nx "and") (if (>= i 1) "\n    " " "))
                   ((= nx "or") (if (>= i 1) "\n   " " "))
                   ((= nx "enumerate") (if (>= i 1) "\n " " "))
                   ((= nx "dotimes") (if (>= i 1) "\n " " "))
                   ((= nx "dolist") (if (>= i 1) "\n " " "))
                   ((= nx "set-handler") (if (>= i 2) "\n " " "))
                   ((= nx "set-style") (if (% i 2) "\n          " " "))
                   ((= nx "defun") (if (>= i 2) "\n " " "))
                   ((= nx "defmethod") (if (>= i 3) "\n " " "))
                   ((and (= nx "setf")
                         (= i 1)
                         (list? (aref x 2))
                         (= (first (aref x 2)) "lambda")) "\n     ")
                   ((= nx "setf") (if (>= i 1) "\n     " " "))
                   ((= nx "lambda") (if (>= i 1) "\n " " "))
                   ((= nx "defmacro") (if (>= i 2) "\n " " "))
                   ((= nx "define-symbol-macro") (if (>= i 2) "\n " " "))
                   ((= nx "js-object") (if (> i 1) "\n           " " "))
                   ((= (slice nx 0 5) "make-")
                    (if (or (< i 2) (% i 2))
                        " "
                        (lpad "\n" (+ 2 (length nx)))))
                   ((= nx "if") (if (>= i 1) "\n   " " "))
                   ((= nx "let") (if (>= i 1) "\n " " "))
                   ((= nx "let*") (if (>= i 1) "\n " " "))
                   ((= nx "let**") (if (>= i 1) "\n " " "))
                   ((= nx "with-window") (if (>= i 1) "\n " " "))
                   ((and (= npx "with-window")
                         (= (index x px) 1))
                    (if (>= i 1) "\n  " " "))
                   ((= npx "cond") "\n")
                   ((= npx "case") "\n")
                   ((= nppx "labels") (if (>= i 1) "\n " " "))
                   ((= nppx "macrolet") (if (>= i 1) "\n " " "))
                   ((= nx "when") (if (>= i 1) "\n " " "))
                   ((= nx "unless") (if (>= i 1) "\n " " "))
                   ((= nx "push") (if (>= i 1) "\n     " " "))
                   (true " "))))
             (dumplist (ppx px x)
               (enumerate (j y x)
                 (dump px x y)
                 (when (< j (1- (length x)))
                   (output (sep ppx px x j)))))
             (dump (ppx px x)
               (cond
                 ((list? x)
                  (cond
                    ((and (= (first x) '\.)
                          (= (length x) 3)
                          (or (string? (third x))
                              (symbol? (third x))))
                     (dump px x (second x))
                     (output ".")
                     (dump px x (third x)))
                    ((and (= (first x) '\`) (= (length x) 2))
                     (output "`")
                     (dump px x (second x)))
                    ((and (= (first x) '\,) (= (length x) 2))
                     (output ",")
                     (dump px x (second x)))
                    ((and (= (first x) '\,@) (= (length x) 2))
                     (output ",@")
                     (dump px x (second x)))
                    ((and (= (first x) 'quote) (= (length x) 2))
                     (output "'")
                     (dump px x (second x)))
                    ((and (= (first x) 'function) (= (length x) 2))
                     (output "#'")
                     (dump px x (second x)))
                    (true
                     (output "(")
                     (dumplist ppx px x)
                     (output ")"))))
                 ((symbol? x)
                  (output (symbol-name x)))
                 (true
                  (output (json x))))
               (when (and (list? x)
                          (find (first x) '(defun defmacro defmethod defvar)))
                 (newline))))
      (dump (list) (list) obj)
      (display result)
      null)))

(export pprint *print-width*)