From: Szymon
Subject: colorified (html) lisp code output (pprinter)
Date:
Message-ID: <87brfrwumy.fsf@eva.rplacd.net>
(defparameter *example-code*
(copy-tree
'(defun get-llk (llst rt-lst
&aux (result-list (make-list (1+ (length rt-lst))))
(tail result-list))
(apply #'values
(mapl (lambda (lst) (rplaca lst (nreverse (car lst))))
(dolist (i llst result-list)
(if (memq i rt-lst)
(setq tail
(nthcdr (1+ (position i rt-lst :test #'eq))
result-list))
(push i (car tail)))))))))
;; ------- I have this:
;; (html-write *example-code*)
;; <pre>
(<code style="color: red">DEFUN</code> GET-LLK
(LLST RT-LST
&AUX
(RESULT-LIST
(MAKE-LIST (1+ (LENGTH RT-LST))))
(TAIL RESULT-LIST))
(APPLY #'VALUES
(MAPL
(<code style="color: red">LAMBDA</code> (LST)
(RPLACA LST (NREVERSE (CAR LST))))
(<code style="color: red">DOLIST</code> (I LLST RESULT-LIST)
(<code style="color: red">IF</code> (MEMQ I RT-LST)
(<code style="color: red">SETQ</code> TAIL
(NTHCDR
(1+
(POSITION
I
RT-LST
:TEST
#'EQ))
RESULT-LIST))
(PUSH I (CAR TAIL)))))))
;; </pre>
;; --------------- my current code:
(progn
(defparameter *PD* (copy-pprint-dispatch))
(defparameter string-style "style=\"color: navy\"")
(defparameter symbol-style "style=\"color: red\"")
(defparameter csyms '(LAMBDA SETF DOLIST DEFPARAMETER SETQ DEFUN IF LOOP DEFVAR blah.. blah..))
(defun html-write (expr &rest args)
(apply #'write expr :pretty t :pprint-dispatch *PD* args))
(flet ((_str_concat (&rest args) (apply #'concatenate 'string args)))
(set-pprint-dispatch 'string
(lambda (s string)
(write-string
(_str_concat "<code " string-style ">" "\"" (string string) "\"" "</code>")
s))
0 *PD*)
(set-pprint-dispatch 'symbol
(lambda (s id)
(write-string
(if (memq id csyms)
(_str_concat "<code " symbol-style ">" (string id) "</code>")
(if (keywordp id)
(_str_concat ":" (string id))
(string id)))
s))
0 *PD*)))
;; --------------- end code.
;; I have not idea how to achieve this: (Is pprinter
;; able to format code like this? (see below))
;; (html-write *example-code*)
;; <pre>
(<code style="color: red">DEFUN</code> GET-LLK (LLST RT-LST
&AUX (RESULT-LIST (MAKE-LIST (1+ (LENGTH RT-LST))))
(TAIL RESULT-LIST))
(APPLY #'VALUES
(MAPL (<code style="color: red">LAMBDA</code> (LST) (RPLACA LST (NREVERSE (CAR LST))))
(<code style="color: red">DOLIST</code> (I LLST RESULT-LIST)
(<code style="color: red">IF</code> (MEMQ I RT-LST)
(<code style="color: red">SETQ</code> TAIL
(NTHCDR (1+ (POSITION I RT-LST :TEST #'EQ))
RESULT-LIST))
(PUSH I (CAR TAIL)))))))
;; </pre>
;; The result I want (colorified of course) in web-browser:
(DEFUN GET-LLK (LLST RT-LST
&AUX (RESULT-LIST (MAKE-LIST (1+ (LENGTH RT-LST))))
(TAIL RESULT-LIST))
(APPLY #'VALUES
(MAPL (LAMBDA (LST) (RPLACA LST (NREVERSE (CAR LST))))
(DOLIST (I LLST RESULT-LIST)
(IF (MEMQ I RT-LST)
(SETQ TAIL
(NTHCDR (1+ (POSITION I RT-LST :TEST #'EQ))
RESULT-LIST))
(PUSH I (CAR TAIL)))))))
I need advice (or/and code).
Regards, Szymon.