Codebase list cafeobj / ca8cfd8
Make 'desc module tree' hide internal module structure. tswd 9 years ago
1 changed file(s) with 44 addition(s) and 40 deletion(s). Raw diff Collapse all Expand all
+44
-40
chaos/tools/module-tree.lisp less more
160160 (let ((info (getf (module-infos arg) 'rename-mod)))
161161 (print-mod-name-x (car info) stream abbrev no-param)
162162 (princ "*DUMMY"))
163 (print-mod-name-internal-x modname abbrev t))
163 (with-in-module (arg)
164 (print-mod-name-internal-x modname abbrev t)))
164165 (let ((params (get-module-parameters arg)))
165166 (when (and params (not no-param))
166167 (let ((flg nil))
167 ;; (princ "[")
168 (princ "(")
168 (princ "[")
169 ;; (princ "(")
169170 (dolist (param params)
170171 (let ((theory (parameter-theory-module param)))
171172 (if flg (princ ", "))
172173 (if (or (null (parameter-context param))
173174 (eq arg (parameter-context param)))
174175 (princ (parameter-arg-name param))
175 (progn
176 ;; (format t "~a@" (parameter-arg-name param))
177 (format t "~a." (parameter-arg-name param))
178 (print-mod-name-x (parameter-context param)
179 stream
180 abbrev
181 t)))
176 (if (not (eq (parameter-context param) arg))
177 (progn
178 (format t "~a." (parameter-arg-name param))
179 (print-mod-name-x (parameter-context param)
180 stream
181 abbrev
182 t))
183 (format t "~a" (parameter-arg-name param))))
182184 ;; patch-begin
183185 (princ "::")
184 ;; (print-mod-name-x theory stream abbrev t)
185186 (print-parameter-theory-name theory stream :abbrev :no-param)
186 ;; patch-end
187187 (setq flg t)))
188 ;; (princ "]")
189 (princ ")")))))
188 (princ "]")
189 ;; (princ ")")
190 ))))
190191 (print-chaos-object arg))))
191192
192193 (defun print-mod-name-internal-x (val abbrev &optional (no-param nil))
193194 (declare (values t))
194195 (if (stringp val)
195196 (princ val)
196 (if (and (consp val) (not (chaos-ast? val)))
197 (if (equal "::" (cadr val))
198 ;; parameter theory
199 (if abbrev
200 (progn
201 (format t "~a" (car val))
202 (princ ".")
203 (print-mod-name-x (car (last val))
204 *standard-output*
205 abbrev no-param))
206 ;;
207 (let ((cntxt (fourth val)))
208 (if (and cntxt
209 (not (eq *current-module* cntxt)))
210 (progn (format t "~a." (car val))
211 (print-mod-name-x cntxt *standard-output* t t)
212 (princ "::"))
213 (format t "~a::" (car val)))
214 (print-mod-name-x (caddr val) *standard-output* nil t)))
215 (print-chaos-object val))
216 (print-modexp val *standard-output* abbrev no-param))))
197 (if (and (consp val) (not (chaos-ast? val)))
198 (if (equal "::" (cadr val))
199 ;; parameter theory
200 (if abbrev
201 (progn
202 (format t "~a" (car val))
203 (princ ".")
204 (print-mod-name-x (car (last val)) *standard-output* abbrev no-param))
205 (let ((cntxt (fourth val)))
206 (if (and cntxt
207 (not (eq *current-module* cntxt)))
208 (progn (format t "~a." (car val))
209 (print-mod-name-x cntxt *standard-output* t t)
210 (princ "::"))
211 (format t "~a::" (car val)))
212 (print-mod-name-x (caddr val) *standard-output* abbrev t)))
213 (print-chaos-object val))
214 (print-modexp val *standard-output* abbrev no-param))))
217215
218216 (defvar .mod-dup-hash. (make-hash-table :test #'eq))
219217
234232 (:modmorph (princ "!" stream))
235233 (otherwise (princ "??" stream))))
236234
235 (defun mod-name-is-parameter (name)
236 (and (consp name)
237 (not (chaos-ast? name))
238 (equal "::" (second name))))
239
237240 (defun d-module-tree* (dag-node stream p-label &optional my-num)
238241 (let* ((mod+imp (dag-node-datum dag-node))
239242 (mod (car mod+imp))
240243 (imp (cdr mod+imp))
241 (*print-line-limit* 80)
244 (*print-line-limit* 100)
242245 (*print-xmode* :fancy)
243246 (num (if (and p-label my-num)
244247 (format nil "~a-~d" p-label my-num)
254257 (let (;; (*print-indent* (+ (max 4 (length num)) *print-indent*)))
255258 (*print-indent* (+ 2 *print-indent*)))
256259 (when num (princ "(" stream))
257 (print-mod-name-x mod stream)
260 ;; (print-mod-name-x mod stream t)
261 (princ (get-module-print-name mod) stream)
258262 (when num (princ ")" stream))
259263 (if dup? (princ "*" stream)
260264 (with-in-module (mod)
261265 (let ((subnodes (dag-node-subnodes dag-node)))
262266 (when subnodes
263 (let ((*print-indent* (+ 2 *print-indent*))
267 (let (;; (*print-indent* (+ 2 *print-indent*))
264268 (y-num 1))
265269 (dolist (sub subnodes)
266270 (let ((subm (car (dag-node-datum sub)))
267271 (sub-imp (cdr (dag-node-datum sub))))
268272 (unless (or (module-hidden subm)
269 (eq sub-imp :modmorph)
270 (equal (module-name subm) "NIL"))
273 (mod-name-is-parameter (get-module-print-name subm))
274 (eq sub-imp :modmorph))
271275 (print-next-prefix #\Space)
272276 (d-module-tree* sub stream num y-num)
273277 (incf y-num))))))))))))