June 2004 - lisppaste-cvs@common-lisp.net

[Lisppaste-cvs] CVS update: lisppaste2/coloring-types.lisp lisppaste2/lisppaste.asd
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: coloring-types.lisp lisppaste.asd Log Message: elisp colorization Date: Thu Jun 3 13:20:46 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.3 lisppaste2/coloring-types.lisp:1.4 --- lisppaste2/coloring-types.lisp:1.3 Thu Jun 3 07:17:04 2004 +++ lisppaste2/coloring-types.lisp Thu Jun 3 13:20:46 2004 @@ -22,10 +22,6 @@ (defparameter *close-parens* '(#\))) (define-coloring-type :lisp "Basic Lisp" - :autodetect (lambda (name) - (member name '("emacs") - :test #'(lambda (name ext) - (search ext name :test #'char-equal)))) :modes (:normal :symbol :escaped-symbol :keyword :string :comment :multiline :character :single-escaped :in-list :syntax-error) @@ -191,6 +187,24 @@ (declare (ignore type)) (let ((result (if (find-package :r5rs-lookup) (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup)) + s)))) + (if result + (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" + result (call-parent-formatter)) + (call-parent-formatter))))))) + +(define-coloring-type :elisp "Emacs Lisp" + :autodetect (lambda (name) + (member name '("emacs") + :test #'(lambda (name ext) + (search ext name :test #'char-equal)))) + :parent :lisp + :formatters + (((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let ((result (if (find-package :elisp-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup)) s)))) (if result (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.10 lisppaste2/lisppaste.asd:1.11 --- lisppaste2/lisppaste.asd:1.10 Thu Jun 3 07:17:58 2004 +++ lisppaste2/lisppaste.asd Thu Jun 3 13:20:46 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.10 2004/06/03 14:17:58 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.11 2004/06/03 20:20:46 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -33,6 +33,7 @@ (:file "colorize" :depends-on ("colorize-package" "coloring-css")) (:file "clhs-lookup" :depends-on ("encode-for-pre")) (:file "r5rs-lookup" :depends-on ("encode-for-pre")) + (:file "elisp-lookup" :depends-on ("encode-for-pre")) (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/r5rs-symbols.lisp-expr lisppaste2/elisp-symbols.lisp-expr lisppaste2/elisp-lookup.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Added Files: r5rs-symbols.lisp-expr elisp-symbols.lisp-expr elisp-lookup.lisp Log Message: Symbols for R5RS and Elisp; lookup for elisp Date: Thu Jun 3 13:20:19 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/encode-for-pre.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: encode-for-pre.lisp Log Message: eight spaces instead of four for tabs Date: Thu Jun 3 13:19:40 2004 Author: bmastenbrook Index: lisppaste2/encode-for-pre.lisp diff -u lisppaste2/encode-for-pre.lisp:1.15 lisppaste2/encode-for-pre.lisp:1.16 --- lisppaste2/encode-for-pre.lisp:1.15 Tue Jun 1 06:17:50 2004 +++ lisppaste2/encode-for-pre.lisp Thu Jun 3 13:19:40 2004 @@ -1,4 +1,4 @@ -;;;; $Id: encode-for-pre.lisp,v 1.15 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: encode-for-pre.lisp,v 1.16 2004/06/03 20:19:40 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -37,7 +37,7 @@ ((#\>) (write-string ">" out)) ((#\Tab) - (write-string "    " out)) + (write-string "        " out)) ((#\Space) (write-char #\Space out) (go escape-spaces))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/package.lisp lisppaste2/lisppaste.lisp lisppaste2/lisppaste.asd
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: package.lisp lisppaste.lisp lisppaste.asd Log Message: package: export shut-up; lisppaste: better response for help; lisppaste.asd: add r5rs-lookup Date: Thu Jun 3 07:17:58 2004 Author: bmastenbrook Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.5 lisppaste2/package.lisp:1.6 --- lisppaste2/package.lisp:1.5 Tue Jun 1 06:18:35 2004 +++ lisppaste2/package.lisp Thu Jun 3 07:17:58 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.5 2004/06/01 13:18:35 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.6 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,6 +8,6 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :lisppaste (:use :cl #+sbcl :sb-bsd-sockets :html-encode) - (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up))) + (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up :say-help))) Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.16 lisppaste2/lisppaste.lisp:1.17 --- lisppaste2/lisppaste.lisp:1.16 Tue Jun 1 06:17:50 2004 +++ lisppaste2/lisppaste.lisp Thu Jun 3 07:17:58 2004 @@ -1,10 +1,29 @@ -;;;; $Id: lisppaste.lisp,v 1.16 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.17 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :lisppaste) +(defun say-help (channel) + (when (and *connection* + (find channel *channels* :test #'string=)) + (irc:privmsg *connection* + channel + (format nil "To use the lisppaste bot, visit ~A/~A and enter your paste." (araneida:urlstring *new-paste-url*) (subseq channel 1))) + t)) + +(defun help-request-p (nick help text) + (and (> (length text) + (length nick)) + (search nick text :start2 0 :end2 (length nick) :test #'char-equal) + (let ((url-position (search help text :start2 (length nick) + :test #'char-equal))) + (and + url-position + (notany #'alphanumericp (subseq text (length nick) (1- url-position))) + (notany #'alphanumericp (subseq text (+ url-position (length help)))))))) + (defun make-msg-hook (nick) (lambda (message) (let ((text (irc:trailing-argument message))) @@ -12,18 +31,10 @@ (irc:privmsg *connection* (irc:source message) (format nil "To use the lisppaste bot, visit ~A and enter your paste. Be sure to select the right channel!" (araneida:urlstring *new-paste-url*)))) - ((and (> (length text) - (length nick)) - (search nick text :start2 0 :end2 (length nick) :test #'char-equal)) - (let ((url-position (search "url" text :start2 (length nick) - :test #'char-equal))) - (if (and - url-position - (notany #'alphanumericp (subseq text (length nick) (1- url-position))) - (notany #'alphanumericp (subseq text (+ url-position 3)))) - (irc:privmsg *connection* - (first (irc:arguments message)) - (format nil "To use the lisppaste bot, visit ~A/~A and enter your paste." (araneida:urlstring *new-paste-url*) (subseq (first (irc:arguments message)) 1)))))))))) + ((some #'(lambda (e) + (help-request-p nick e text)) + '("url" "help" "hello")) + (say-help (first (irc:arguments message)))))))) (defun add-hook (nick) @@ -44,6 +55,7 @@ (setf *channels* channels) (read-pastes-from-file *paste-file*) (mapcar #'(lambda (channel) (irc:join connection channel)) channels) + (clhs-lookup:populate-table) (araneida:start-listening *paste-listener*) (add-hook nickname) (setf *boot-time* (get-universal-time)) Index: lisppaste2/lisppaste.asd diff -u lisppaste2/lisppaste.asd:1.9 lisppaste2/lisppaste.asd:1.10 --- lisppaste2/lisppaste.asd:1.9 Tue Jun 1 06:19:22 2004 +++ lisppaste2/lisppaste.asd Thu Jun 3 07:17:58 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: lisppaste.asd,v 1.9 2004/06/01 13:19:22 bmastenbrook Exp $ +;;;; $Id: lisppaste.asd,v 1.10 2004/06/03 14:17:58 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -22,15 +22,17 @@ pre-configured IRC channel about the paste and where it can be located." :depends-on (:araneida :cl-irc) - :components ((:file "package") + :components ((:file "encode-for-pre") + (:file "package" :depends-on ("encode-for-pre")) (:file "variable" :depends-on ("package")) - (:file "encode-for-pre" - :depends-on ("variable")) (:file "lisppaste" :depends-on ("variable")) - (:file "colorize") - (:file "clhs-lookup") + (:file "colorize-package") + (:file "coloring-css" :depends-on ("colorize-package")) + (:file "colorize" :depends-on ("colorize-package" "coloring-css")) + (:file "clhs-lookup" :depends-on ("encode-for-pre")) + (:file "r5rs-lookup" :depends-on ("encode-for-pre")) (:file "coloring-types" :depends-on ("colorize" "clhs-lookup")) (:file "web-server"

1 0

[Lisppaste-cvs] CVS update: lisppaste2/colorize.lisp lisppaste2/coloring-types.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: colorize.lisp coloring-types.lisp Log Message: MORE ANGRY FRUITS! (paren colorization with CSS :hover) Date: Thu Jun 3 07:17:04 2004 Author: bmastenbrook Index: lisppaste2/colorize.lisp diff -u lisppaste2/colorize.lisp:1.1 lisppaste2/colorize.lisp:1.2 --- lisppaste2/colorize.lisp:1.1 Tue Jun 1 06:17:50 2004 +++ lisppaste2/colorize.lisp Thu Jun 3 07:17:04 2004 @@ -1,10 +1,5 @@ ;;;; colorize.lisp -(defpackage :colorize (:use :common-lisp) - (:export :scan-string :format-scan - :find-coloring-type :autodetect-coloring-type - :coloring-types :scan :scan-any :advance :call-parent-formatter :colorize-file - :*coloring-css*)) (in-package :colorize) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -16,6 +11,8 @@ (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions) (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name) (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter) + (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil) + (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly "")) (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function :initform (constantly nil)) (parent-type :initarg :parent-type :accessor coloring-type-parent-type @@ -61,9 +58,8 @@ (defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body) (with-gensyms (num items position not-preceded-by string item new-mode until advancing) `(labels ((advance (,num) - (when (> (length ,string-param) (+ ,position-place ,num)) - (setf ,position-place (+ ,position-place ,num)) - t)) + (setf ,position-place (+ ,position-place ,num)) + t) (scan-any (,items &key ,not-preceded-by) (incf *scan-calls*) (let* ((,items (if (stringp ,items) @@ -116,38 +112,59 @@ (list 'values ,until ,advancing))))))) ,@body)))) +(defvar *formatter-local-variables*) + (defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters - autodetect parent) + autodetect parent formatter-variables (formatter-after-hook '(constantly ""))) (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance) `(let ((,parent-type (or (find-coloring-type ,parent) (and ,parent (error "No such coloring type: ~S" ,parent))))) (setf (find-coloring-type ,name) (make-instance 'coloring-type - :fancy-name ',fancy-name - :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type))) - :default-mode (or ',default-mode - (if ,parent-type (coloring-type-default-mode ,parent-type))) - ,@(if autodetect - `(:autodetect-function ,autodetect)) - :parent-type ,parent-type - :term-formatter - (lambda (,term) - (labels ((call-parent-formatter (&optional (,type (car ,term)) - (,string (cdr ,term))) - (if ,parent-type - (funcall (coloring-type-term-formatter ,parent-type) - (cons ,type ,string)))) - (call-formatter (&optional (,type (car ,term)) - (,string (cdr ,term))) - (funcall - (case (first ,type) - ,@formatters - (t (lambda (,type text) - (call-parent-formatter ,type text)))) - ,type ,string))) - (call-formatter))) - :transition-functions + :fancy-name ',fancy-name + :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type))) + :default-mode (or ',default-mode + (if ,parent-type (coloring-type-default-mode ,parent-type))) + ,@(if autodetect + `(:autodetect-function ,autodetect)) + :parent-type ,parent-type + :formatter-initial-values (lambda nil + (list* ,@(mapcar #'(lambda (e) + `(cons ',(car e) ,(second e))) + formatter-variables) + (if ,parent-type + (funcall (coloring-type-formatter-initial-values ,parent-type)) + nil))) + :formatter-after-hook (lambda nil + (symbol-macrolet ,(mapcar #'(lambda (e) + `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) + formatter-variables) + (concatenate 'string + (funcall ,formatter-after-hook) + (if ,parent-type + (funcall (coloring-type-formatter-after-hook ,parent-type)) + "")))) + :term-formatter + (symbol-macrolet ,(mapcar #'(lambda (e) + `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) + formatter-variables) + (lambda (,term) + (labels ((call-parent-formatter (&optional (,type (car ,term)) + (,string (cdr ,term))) + (if ,parent-type + (funcall (coloring-type-term-formatter ,parent-type) + (cons ,type ,string)))) + (call-formatter (&optional (,type (car ,term)) + (,string (cdr ,term))) + (funcall + (case (first ,type) + ,@formatters + (t (lambda (,type text) + (call-parent-formatter ,type text)))) + ,type ,string))) + (call-formatter)))) + :transition-functions (list ,@(loop for transition in transitions collect (destructuring-bind (mode &rest table) transition @@ -202,7 +219,7 @@ current-position new-position current-wait new-wait)))) (loop - (if (>= current-position (length string)) + (if (> current-position (length string)) (return-from scan-string (progn (format t "Scan was called ~S times.~%" @@ -230,6 +247,8 @@ (multiple-value-bind (pos advance) (funcall current-wait current-position) + #+nil + (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position) (and pos (when (> pos current-position) (finish-current (if advance @@ -247,9 +266,11 @@ (defun format-scan (coloring-type scan) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error "No such coloring type: ~S" coloring-type))) - (color-formatter (coloring-type-term-formatter coloring-type-object))) - (format nil "~{~A~}" - (mapcar color-formatter scan)))) + (color-formatter (coloring-type-term-formatter coloring-type-object)) + (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object)))) + (format nil "~{~A~}~A" + (mapcar color-formatter scan) + (funcall (coloring-type-formatter-after-hook coloring-type-object))))) (defun colorize-file (coloring-type input-file-name &optional output-file-name) (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) @@ -258,7 +279,8 @@ :defaults (merge-pathnames input-file-name)))) (output-file (or output-file-name (make-pathname :type "html" - :defaults input-file)))) + :defaults input-file))) + (*css-background-class* "default")) (with-open-file (s input-file :direction :input) (let ((lines nil) (string nil)) @@ -271,11 +293,21 @@ (nreverse lines))) (with-open-file (s2 output-file :direction :output :if-exists :supersede) (format s2 - "<html><head><style type=\"text/css\">~A</style><body><tt>~A</tt></body></html>" + "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\"> +<html><head><style type=\"text/css\">~A~%~A</style><body> +<table width=\"100%\"><tr><td class=\"~A\"> +<tt>~A</tt> +</tr></td></table></body></html>" *coloring-css* + (make-background-css "white") + *css-background-class* (format-scan coloring-type (mapcar #'(lambda (p) (cons (car p) - (html-encode:encode-for-tt (cdr p)))) + (let ((tt + (html-encode:encode-for-tt (cdr p)))) + (if (and (> (length tt) 0) + (char= (elt tt (1- (length tt))) #\>)) + (format nil "~A~%" tt) tt)))) (scan-string coloring-type - string))))))))) \ No newline at end of file + string))))))))) Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.2 lisppaste2/coloring-types.lisp:1.3 --- lisppaste2/coloring-types.lisp:1.2 Tue Jun 1 06:41:27 2004 +++ lisppaste2/coloring-types.lisp Thu Jun 3 07:17:04 2004 @@ -2,26 +2,12 @@ (in-package :colorize) -(defparameter *coloring-css* - ".symbol { color : #770055; background-color : inherit; } -a.symbol:link { color : #229955; background-color : inherit; text-decoration: underline; } -a.symbol:active { color : #229955; background-color : inherit; text-decoration: underline; } -a.symbol:visited { color : #229955; background-color : inherit; text-decoration: underline; } -a.symbol:hover { color : #229955; background-color : inherit; text-decoration: underline; } -.special { color : #FF5000; background-color : inherit; } -.keyword { color : #770000; background-color : inherit; } -.comment { color : #007777; background-color : inherit; } -.string { color : #777777; background-color : inherit; } -.character { color : #0055AA; background-color : inherit; } -.syntaxerror { color : #FF0000; background-color : inherit; } -") - (defparameter *symbol-characters* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&") (defparameter *non-constituent* '(#\space #\tab #\newline #\linefeed #\page #\return - #\" #\' #$ #$ #\, #\; #\`)) + #\" #\' #$ #$ #\, #\; #\` #\[ #\])) (defparameter *special-forms* '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the" @@ -32,6 +18,9 @@ (defparameter *common-macros* '("loop" "cond" "lambda")) +(defparameter *open-parens* '(#$)) +(defparameter *close-parens* '(#$)) + (define-coloring-type :lisp "Basic Lisp" :autodetect (lambda (name) (member name '("emacs") @@ -39,21 +28,10 @@ (search ext name :test #'char-equal)))) :modes (:normal :symbol :escaped-symbol :keyword :string :comment :multiline :character - :single-escaped :in-list :dotted-list-tail :syntax-error) + :single-escaped :in-list :syntax-error) :default-mode :normal :transitions - (#| - ((:in-list) - ((scan #\.) - (set-mode :dotted-list-tail - :until (scan #\)) - :advancing nil))) - ((:dotted-list-tail) - ((scan #\.) - (set-mode :syntax-error - :until (scan #\)) - :advancing nil)))|# - ((:normal :in-list :dotted-list-tail) + (((:normal :in-list) ((or (scan-any *symbol-characters*) (and (scan "+") (scan-any *symbol-characters*)) @@ -68,9 +46,6 @@ (set-mode :keyword :until (scan-any *non-constituent*) :advancing nil)) - ((scan #\|) - (set-mode :escaped-symbol - :until (scan #\|))) ((scan "#\\") (let ((count 0)) (set-mode :character @@ -103,14 +78,47 @@ (incf count) (if (< count 2) (advance 1)))))))) + :formatter-variables ((paren-counter 0)) + :formatter-after-hook (lambda nil + (format nil "~{~A~}" + (loop for i from paren-counter downto 1 + collect "</span></span>"))) :formatters ((:normal (lambda (type s) (declare (ignore type)) s)) - ((:in-list :dotted-list-tail) + ((:in-list) (lambda (type s) (declare (ignore type)) - s)) + (labels ((color-parens (s) + (let ((paren-pos (find-if-not #'null + (mapcar #'(lambda (c) + (position c s)) + (append *open-parens* + *close-parens*))))) + (if paren-pos + (let ((before-paren (subseq s 0 paren-pos)) + (after-paren (subseq s (1+ paren-pos))) + (paren (elt s paren-pos)) + (open nil) + (count 0)) + (when (member paren *open-parens* :test #'char=) + (setf count (mod paren-counter 6)) + (incf paren-counter) + (setf open t)) + (when (member paren *close-parens* :test #'char=) + (decf paren-counter)) + (if open + (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A" + before-paren + (1+ count) + paren *css-background-class* + (color-parens after-paren)) + (format nil "~A</span>~C</span>~A" + before-paren + paren (color-parens after-paren)))) + s)))) + (color-parens s)))) ((:symbol :escaped-symbol) (lambda (type s) (declare (ignore type)) @@ -163,16 +171,41 @@ (search "scheme" text :test #'char-equal)) :parent :lisp :transitions - (((:normal :in-list :dotted-list-tail) + (((:normal :in-list) ((scan "...") (set-mode :symbol :until (scan-any *non-constituent*) - :advancing nil))))) + :advancing nil)) + ((scan #\[) + (set-mode :in-list + :until (scan #\]))))) + :formatters + (((:in-list) + (lambda (type s) + (declare (ignore type s)) + (let ((*open-parens* (cons #\[ *open-parens*)) + (*close-parens* (cons #\] *close-parens*))) + (call-parent-formatter)))) + ((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let ((result (if (find-package :r5rs-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup)) + s)))) + (if result + (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" + result (call-parent-formatter)) + (call-parent-formatter))))))) (define-coloring-type :common-lisp "Common Lisp" :autodetect (lambda (text) (search "lisp" text :test #'char-equal)) :parent :lisp + :transitions + (((:normal :in-list) + ((scan #\|) + (set-mode :escaped-symbol + :until (scan #\|))))) :formatters (((:symbol :escaped-symbol) (lambda (type s)

1 0

[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: web-server.lisp Log Message: Adventures in compliant HTML and class-ification Date: Thu Jun 3 07:16:35 2004 Author: bmastenbrook Index: lisppaste2/web-server.lisp diff -u lisppaste2/web-server.lisp:1.48 lisppaste2/web-server.lisp:1.49 --- lisppaste2/web-server.lisp:1.48 Tue Jun 1 06:17:50 2004 +++ lisppaste2/web-server.lisp Thu Jun 3 07:16:35 2004 @@ -1,20 +1,24 @@ -;;;; $Id: web-server.lisp,v 1.48 2004/06/01 13:17:50 bmastenbrook Exp $ +;;;; $Id: web-server.lisp,v 1.49 2004/06/03 14:16:35 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :lisppaste) -(defstruct paste - (number nil :type integer) - (user nil :type string) - (title nil :type string) - (contents nil :type string) - (universal-time nil :type integer) - (is-annotation nil :type boolean) - (annotations nil :type list) - (annotation-counter 0 :type integer) - (channel "" :type string)) +(defclass paste () + ((number :initarg :number :initform 0 :accessor paste-number) + (user :initarg :user :initform "" :accessor paste-user) + (title :initarg :title :initform "" :accessor paste-title) + (contents :initarg :contents :initform "" :accessor paste-contents) + (universal-time :initarg :universal-time :initform 0 :accessor paste-universal-time) + (is-annotation :initarg :is-annotation :initform nil :accessor paste-is-annotation) + (annotations :initarg :annotations :initform nil :accessor paste-annotations) + (annotation-counter :initarg :annotation-counter :initform 0 :accessor paste-annotation-counter) + (channel :initarg :channel :initform "" :accessor paste-channel) + (colorization-mode :initarg :colorization-mode :initform "" :accessor paste-colorization-mode))) + +(defmacro make-paste (&rest arguments) + `(make-instance 'paste ,@arguments)) (defclass new-paste-handler (araneida:handler) ()) @@ -92,7 +96,7 @@ (t (format nil "~A~A" (time-delta-primitive delta level) (if ago-p " ago" "")))))) (defun irc-log-link (utime channel) - (format nil "http://meme.b9.com/now?utime=~A&channel=~A" + (format nil "http://meme.b9.com/now?utime=~A&channel=~A" utime (string-left-trim "#" channel))) @@ -580,7 +584,8 @@ (car (rassoc colorize-string (colorize:coloring-types) :test #'string-equal)) (if (and paste (not (string-equal colorize-string "None"))) - (colorize:autodetect-coloring-type (paste-channel paste)))))) + (colorize:autodetect-coloring-type (paste-channel paste))))) + (colorize:*css-background-class* "paste")) (if paste (if raw (let ((p (position #\, (araneida::request-unhandled-part request) :test #'char=))) @@ -606,12 +611,14 @@ (head (title "Paste number " ,paste-number) ((style :type "text/css") - ,colorize:*coloring-css*) + ,(format nil "~A~%~A~%" + (colorize:make-background-css "#F4F4F4") + colorize:*coloring-css*)) ,(rss-link-header)) (body ,(format-paste paste (araneida:urlstring (araneida:request-url request)) paste-number nil colorize-as) - ,(if (paste-annotations paste) - `(p + ,@(if (paste-annotations paste) + `((p) "Annotations for this paste: " ,@(reduce #'append (mapcar #'(lambda (a) @@ -621,7 +628,8 @@ (araneida:urlstring (araneida:request-url request)) (paste-number a)) (paste-number a) t colorize-as))) (reverse (paste-annotations paste))))) - `(p "This paste has no annotations.")) + `((p) "This paste has no annotations.")) + (p) ((form :method post :action ,(araneida:urlstring (araneida:merge-url *display-paste-url* @@ -634,7 +642,7 @@ ,@(if (eq (car pair) colorize-as) - '(:selected "true"))) + '(:selected "SELECTED"))) ,(cdr pair))) (colorize:coloring-types))) ((input :type submit :value "Colorize")))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/clhs-lookup.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: clhs-lookup.lisp Log Message: Add back MOP and format lookup Date: Thu Jun 3 07:16:16 2004 Author: bmastenbrook Index: lisppaste2/clhs-lookup.lisp diff -u lisppaste2/clhs-lookup.lisp:1.1 lisppaste2/clhs-lookup.lisp:1.2 --- lisppaste2/clhs-lookup.lisp:1.1 Tue Jun 1 06:41:27 2004 +++ lisppaste2/clhs-lookup.lisp Thu Jun 3 07:16:16 2004 @@ -1,9 +1,9 @@ (defpackage :clhs-lookup (:use :common-lisp) (:export :symbol-lookup - :populate-table)) + :populate-table + :spec-lookup)) (in-package :clhs-lookup) -;;; CLHS. This will be the default lookup. -(defparameter *hyperspec-pathname* #p"/Users/chandler/HyperSpec/") +(defparameter *hyperspec-pathname* #p"/home/bmastenbrook/HyperSpec/") (defparameter *hyperspec-map-file* (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*)) @@ -14,8 +14,20 @@ (defparameter *mop-root* "http://www.alu.org/mop/") -(defvar *table* (make-hash-table :test 'equalp)) +(defvar *symbol-table* (make-hash-table :test 'equalp)) + +(defvar *section-table* (make-hash-table :test 'equalp)) + +(defvar *format-table* (make-hash-table :test 'equalp)) +(defun add-clhs-section-to-table (&rest numbers) + (let ((key (format nil "~{~d~^.~}" numbers)) + (target (concatenate 'string *hyperspec-root* (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers)))))) + (setf (gethash key *section-table*) target))) + +(defun valid-target (&rest numbers) + (probe-file (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers))))) + (defun populate-table () ;; Hyperspec (with-open-file (s *hyperspec-map-file*) @@ -24,24 +36,97 @@ (do ((symbol-name (read-line s nil s) (read-line s nil s)) (url (read-line s nil s) (read-line s nil s))) ((eq url s) 'done) - (setf (gethash symbol-name *table*) (concatenate 'string *hyperspec-root* (subseq url 3)))) + (setf (gethash symbol-name *symbol-table*) (concatenate 'string *hyperspec-root* (subseq url 3)))) + ;; add in section references. + (let ((*default-pathname-defaults* *hyperspec-pathname*)) + ;; Yuk. I know. Fixes welcome. + (loop for section from 0 to 27 + do (add-clhs-section-to-table section) + do (loop named s for s1 from 1 to 26 + unless (valid-target section s1) + do (return-from s nil) + do (add-clhs-section-to-table section s1) + do (loop named ss for s2 from 1 to 26 + unless (valid-target section s1 s2) + do (return-from ss nil) + do (add-clhs-section-to-table section s1 s2) + do (loop named sss for s3 from 1 to 26 + unless (valid-target section s1 s2 s3) + do (return-from sss nil) + do (add-clhs-section-to-table section s1 s2 s3) + do (loop named ssss for s4 from 1 to 26 + unless (valid-target section s1 s2 s3 s4) + do (return-from ssss nil) + do (add-clhs-section-to-table section s1 s2 s3 s4) + do (loop named sssss for s5 from 1 to 26 + unless (valid-target section s1 s2 s3 s4 s5) + do (return-from sssss nil) + do (add-clhs-section-to-table section s1 s2 s3 s4 s5)))))))) + ;; format directives + (loop for code from 32 to 127 + do (setf (gethash (format nil "~~~A" (code-char code)) *format-table*) + (concatenate 'string + *hyperspec-root* + (case (code-char code) + ((#\c #\C) "Body/22_caa.htm") + ((#\%) "Body/22_cab.htm") + ((#\&) "Body/22_cac.htm") + ((#\|) "Body/22_cad.htm") + ((#\~) "Body/22_cae.htm") + ((#\r #\R) "Body/22_cba.htm") + ((#\d #\D) "Body/22_cbb.htm") + ((#\b #\B) "Body/22_cbc.htm") + ((#\o #\O) "Body/22_cbd.htm") + ((#\x #\X) "Body/22_cbe.htm") + ((#\f #\F) "Body/22_cca.htm") + ((#\e #\E) "Body/22_ccb.htm") + ((#\g #\G) "Body/22_ccc.htm") + ((#\$) "Body/22_ccd.htm") + ((#\a #\A) "Body/22_cda.htm") + ((#\s #\S) "Body/22_cdb.htm") + ((#\w #\W) "Body/22_cdc.htm") + ((#\_) "Body/22_cea.htm") + ((#\<) "Body/22_ceb.htm") + ((#\i #\I) "Body/22_cec.htm") + ((#\/) "Body/22_ced.htm") + ((#\t #\T) "Body/22_cfa.htm") + ;; FIXME + ((#\<) "Body/22_cfb.htm") + ((#\>) "Body/22_cfc.htm") + ((#\*) "Body/22_cga.htm") + ((#\[) "Body/22_cgb.htm") + ((#\]) "Body/22_cgc.htm") + ((#\{) "Body/22_cgd.htm") + ((#\}) "Body/22_cge.htm") + ((#\?) "Body/22_cgf.htm") + ((#$) "Body/22_cha.htm") + ((#$) "Body/22_chb.htm") + ((#\p #\P) "Body/22_chc.htm") + ((#\;) "Body/22_cia.htm") + ((#\^) "Body/22_cib.htm") + ((#\Newline) "Body/22_cic.htm") + (t "Body/22_c.htm"))))) ;; glossary. ) ;; MOP - (with-open-file (s *mop-map-file* :if-does-not-exist nil) - (when s - (do ((symbol-name (read-line s nil s) (read-line s nil s)) - (url (read-line s nil s) (read-line s nil s))) - ((eq url s) 'done) - (setf (gethash (concatenate 'string "MOP:" symbol-name) *table*) (concatenate 'string *mop-root* url)))))) - -(defmacro aif (test conseq &optional (else nil)) - `(let ((it ,test)) - (if it ,conseq - (symbol-macrolet ((it ,test)) - ,else)))) - -(defun symbol-lookup (str) - (aif (gethash str *table*) - it - nil)) + (with-open-file (s *mop-map-file*) + (do ((symbol-name (read-line s nil s) (read-line s nil s)) + (url (read-line s nil s) (read-line s nil s))) + ((eq url s) 'done) + (setf (gethash (concatenate 'string "MOP:" symbol-name) *symbol-table*) (concatenate 'string *mop-root* url))))) + +(defun spec-lookup (term &key (type :all)) + (ecase type + (:all + (or (gethash term *symbol-table*) + (gethash term *section-table*) + (gethash term *format-table*))) + (:symbol + (gethash term *symbol-table*)) + (:section + (gethash term *section-table*)) + (:format + (gethash term *format-table*)))) + +(defun symbol-lookup (term) + (spec-lookup term :type :symbol))

1 0

[Lisppaste-cvs] CVS update: lisppaste2/Mop_Sym.txt
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Added Files: Mop_Sym.txt Log Message: Add MOP index file Date: Thu Jun 3 07:15:31 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/r5rs-lookup.lisp
by Brian Mastenbrook 03 Jun '04

03 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Added Files: r5rs-lookup.lisp Log Message: R5RS symbol lookup Date: Thu Jun 3 07:14:45 2004 Author: bmastenbrook

1 0

[Lisppaste-cvs] CVS update: lisppaste2/clhs-lookup.lisp lisppaste2/coloring-types.lisp
by Brian Mastenbrook 01 Jun '04

01 Jun '04

Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/tmp/cvs-serv10256 Modified Files: coloring-types.lisp Added Files: clhs-lookup.lisp Log Message: Fix CLHS lookup Date: Tue Jun 1 06:41:27 2004 Author: bmastenbrook Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.1 lisppaste2/coloring-types.lisp:1.2 --- lisppaste2/coloring-types.lisp:1.1 Tue Jun 1 06:17:50 2004 +++ lisppaste2/coloring-types.lisp Tue Jun 1 06:41:27 2004 @@ -42,7 +42,8 @@ :single-escaped :in-list :dotted-list-tail :syntax-error) :default-mode :normal :transitions - (((:in-list) + (#| + ((:in-list) ((scan #\.) (set-mode :dotted-list-tail :until (scan #\)) @@ -51,7 +52,7 @@ ((scan #\.) (set-mode :syntax-error :until (scan #\)) - :advancing nil))) + :advancing nil)))|# ((:normal :in-list :dotted-list-tail) ((or (scan-any *symbol-characters*) @@ -178,8 +179,8 @@ (declare (ignore type)) (let* ((colon (position #\: s :from-end t :test #'char=)) (to-lookup (if colon (subseq s (1+ colon)) s)) - (result (if (find-package :clhs) - (funcall (symbol-function (intern "FUNCTION-LOOKUP" :clhs)) + (result (if (find-package :clhs-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup)) to-lookup)))) (if result (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"

1 0