Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Backport changes from lisppaste 2.3. (i.e. haskell, erlang, python, etc)

  • Loading branch information...
commit 499e33ecc0b9c8dd366998c6c0a062f38d313133 1 parent d471483
@redline6561 authored
View
5 clhs-lookup.lisp
@@ -15,7 +15,8 @@
;;; AMOP.
(defparameter *mop-map-file*
- (merge-pathnames "Mop_Sym.txt" #.*compile-file-pathname*))
+ (merge-pathnames "Mop_Sym.txt"
+ (or #.*compile-file-truename* *default-pathname-defaults*)))
(defparameter *mop-root* "http://www.alu.org/mop/")
@@ -30,7 +31,7 @@
(defvar *read-macro-table* (make-hash-table :test 'equalp))
(defvar *populated-p* nil)
-
+
(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))))))
View
13 coloring-css.lisp
@@ -12,13 +12,26 @@ a.symbol:hover { color : #229955; background-color : transparent; text-decoratio
.keyword { color : #770000; background-color : inherit; }
.comment { color : #007777; background-color : inherit; }
.string { color : #777777; background-color : inherit; }
+.atom { color : #314F4F; background-color : inherit; }
+.macro { color : #FF5000; background-color : inherit; }
+.variable { color : #36648B; background-color : inherit; }
+.function { color : #8B4789; background-color : inherit; }
+.attribute { color : #FF5000; background-color : inherit; }
.character { color : #0055AA; background-color : inherit; }
.syntaxerror { color : #FF0000; background-color : inherit; }
+.diff-deleted { color : #5F2121; background-color : inherit; }
+.diff-added { color : #215F21; background-color : inherit; }
+span.paren1 { background-color : inherit; -webkit-transition: background-color 0.2s linear; }
span.paren1:hover { color : inherit; background-color : #BAFFFF; }
+span.paren2 { background-color : inherit; -webkit-transition: background-color 0.2s linear; }
span.paren2:hover { color : inherit; background-color : #FFCACA; }
+span.paren3 { background-color : inherit; -webkit-transition: background-color 0.2s linear; }
span.paren3:hover { color : inherit; background-color : #FFFFBA; }
+span.paren4 { background-color : inherit; -webkit-transition: background-color 0.2s linear; }
span.paren4:hover { color : inherit; background-color : #CACAFF; }
+span.paren5 { background-color : inherit; -webkit-transition: background-color 0.2s linear; }
span.paren5:hover { color : inherit; background-color : #CAFFCA; }
+span.paren6 { background-color : inherit; -webkit-transition: background-color 0.2s linear; }
span.paren6:hover { color : inherit; background-color : #FFBAFF; }
")
View
701 coloring-types.lisp
@@ -25,12 +25,9 @@
(defparameter *close-parens* '(#\)))
(define-coloring-type :lisp "Basic Lisp"
- :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
- :multiline :character
- :single-escaped :in-list :syntax-error)
- :default-mode :normal
+ :default-mode :first-char-on-line
:transitions
- (((:normal :in-list)
+ (((:in-list)
((or
(scan-any *symbol-characters*)
(and (scan #\.) (scan-any *symbol-characters*))
@@ -62,6 +59,20 @@
((scan #\()
(set-mode :in-list
:until (scan #\)))))
+ ((:normal :first-char-on-line)
+ ((scan #\()
+ (set-mode :in-list
+ :until (scan #\)))))
+ (:first-char-on-line
+ ((scan #\;)
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#")))
+ ((advance 1)
+ (set-mode :normal
+ :until (scan #\newline))))
(:multiline
((scan "#|")
(set-mode :multiline
@@ -80,7 +91,7 @@
(loop for i from paren-counter downto 1
collect "</span></span>")))
:formatters
- ((:normal
+ (((:normal :first-char-on-line)
(lambda (type s)
(declare (ignore type))
s))
@@ -164,10 +175,6 @@
s)))))
(define-coloring-type :scheme "Scheme"
- :autodetect (lambda (text)
- (or
- (search "scheme" text :test #'char-equal)
- (search "chicken" text :test #'char-equal)))
:parent :lisp
:transitions
(((:normal :in-list)
@@ -197,10 +204,6 @@
(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)
@@ -215,8 +218,6 @@
(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)
@@ -237,6 +238,11 @@
result (call-parent-formatter))
(call-parent-formatter)))))))
+(define-coloring-type :common-lisp-file "Common Lisp File"
+ :parent :common-lisp
+ :default-mode :in-list
+ :invisible t)
+
(defvar *c-open-parens* "([{")
(defvar *c-close-parens* ")]}")
@@ -249,15 +255,17 @@
"switch" "typedef" "union" "unsigned" "void"
"volatile" "while" "__restrict" "_Bool"))
+(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
+(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
+
(define-coloring-type :basic-c "Basic C"
- :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
:default-mode :normal
:invisible t
:transitions
((:normal
- ((scan-any "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
+ ((scan-any *c-begin-word*)
(set-mode :word-ish
- :until (scan-any '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
+ :until (scan-any *c-terminators*)
:advancing nil))
((scan "/*")
(set-mode :comment
@@ -344,6 +352,10 @@
((:normal
((scan #\#)
(set-mode :preprocessor
+ :until (scan-any '(#\return #\newline)))))
+ (:normal
+ ((scan "//")
+ (set-mode :comment
:until (scan-any '(#\return #\newline))))))
:formatters
((:preprocessor
@@ -369,10 +381,7 @@
(define-coloring-type :c++ "C++"
:parent :c
:transitions
- ((:normal
- ((scan "//")
- (set-mode :comment
- :until (scan-any '(#\return #\newline))))))
+ ()
:formatters
((:word-ish
(lambda (type s)
@@ -404,3 +413,649 @@
(format nil "<span class=\"symbol\">~A</span>"
s)
s)))))
+
+(let ((terminate-next nil))
+ (define-coloring-type :objective-c "Objective C"
+ :transitions
+ ((:normal
+ ((scan #\[)
+ (set-mode :begin-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\])
+ (set-mode :end-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (or
+ (and (peek-any '(#\:))
+ (setf terminate-next t))
+ (and terminate-next (progn
+ (setf terminate-next nil)
+ (advance 1)))
+ (scan-any *c-terminators*))
+ :advancing nil)))
+ (:word-ish
+ #+nil
+ ((scan #\:)
+ (format t "hi~%")
+ (set-mode :word-ish :until (advance 1) :advancing nil)
+ (setf terminate-next t))))
+ :parent :c++
+ :formatter-variables ((is-keyword nil) (in-message-send nil))
+ :formatters
+ ((:begin-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send t)
+ (call-formatter (cons :paren-ish type) s)))
+ (:end-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send nil)
+ (call-formatter (cons :paren-ish type) s)))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (prog1
+ (let ((result (if (find-package :cocoa-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result s)
+ (if (member s *c-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ (if in-message-send
+ (if is-keyword
+ (format nil "<span class=\"keyword\">~A</span>" s)
+ s)
+ s))))
+ (setf is-keyword (not is-keyword))))))))
+
+
+(defvar *erlang-open-parens* "([{")
+(defvar *erlang-close-parens* ")]}")
+
+(defvar *erlang-reserved-words*
+ '("after" "andalso" "begin" "catch" "case" "end" "fun" "if" "of" "orelse"
+ "receive" "try" "when" "query" "is_atom" "is_binary" "is_constant"
+ "is_float" "is_function" "is_integer" "is_list" "is_number" "is_pid"
+ "is_port" "is_reference" "is_tuple" "is_record" "abs" "element" "float"
+ "hd" "tl" "length" "node" "round" "self" "size" "trunc" "alive" "apply"
+ "atom_to_list" "binary_to_list" "binary_to_term" "concat_binary"
+ "date" "disconnect_node" "erase" "exit" "float_to_list" "garbage_collect"
+ "get" "get_keys" "group_leader" "halt" "integer_to_list" "internal_bif"
+ "link" "list_to_atom" "list_to_binary" "list_to_float" "list_to_integer"
+ "make_ref" "node_link" "node_unlink" "notalive" "open_port" "pid_to_list"
+ "process_flag" "process_info" "processes" "put" "register" "registered"
+ "setelement" "spawn" "spawn_link" "split_binary" "statistics"
+ "term_to_binary" "time" "throw" "trace" "trunc" "tuple_to_list"
+ "unlink" "unregister" "whereis"))
+
+(defparameter *erlang-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
+(defparameter *erlang-begin-fun* "abcdefghijklmnopqrstuvwxyz")
+(defparameter *erlang-begin-var* "ABCDEFGHIJKLMNOPQRSTUVWXYZ_")
+(defparameter *erlang-terminators* '(#\space #\return #\tab #\newline #\. #\; #\, #\/ #\- #\* #\+ #\( #\) #\' #\" #\[ #\] #\< #\> #\{ #\}))
+
+(define-coloring-type :erlang "Erlang"
+ :default-mode :first-char-on-line
+ :transitions
+ (((:normal :paren-ish)
+ ((scan "%")
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan-any *erlang-begin-var*)
+ (set-mode :variable
+ :until (scan-any *erlang-terminators*)
+ :advancing nil))
+ ((scan-any *erlang-begin-word*)
+ (set-mode :word-ish
+ :until (scan-any *erlang-terminators*)
+ :advancing nil))
+ ((or
+ (scan-any *erlang-open-parens*)
+ (scan-any *erlang-close-parens*))
+ (set-mode :paren-ish
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((scan #\')
+ (set-mode :atom
+ :until (scan #\')))
+ ((scan #\?)
+ (set-mode :macro
+ :until (scan-any *erlang-terminators*)))
+ ((scan #\$)
+ (set-mode :char
+ :until (scan-any *erlang-terminators*)))
+ ((scan #\newline)
+ (set-mode :first-char-on-line)))
+
+ ((:function :attribute)
+ ((or
+ (scan-any *erlang-open-parens*)
+ (scan-any *erlang-close-parens*))
+ (set-mode :paren-ish
+ :until (advance 1)
+ :advancing nil))
+ ((scan-any *erlang-terminators*)
+ (set-mode :normal
+ :until (scan #\newline))))
+
+ (:first-char-on-line
+ ((scan "%")
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan-any *erlang-begin-fun*)
+ (set-mode :function
+ :until (scan #\newline)
+ :advancing nil))
+ ((scan "-")
+ (set-mode :attribute
+ :until (scan #\newline)
+ :advancing nil))
+ ((advance 1)
+ (set-mode :normal
+ :until (scan #\newline))))
+ (:string
+ ((scan #\\)
+ (set-mode :single-escape
+ :until (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 :first-char-on-line)
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ (:comment
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ (:string
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ (:variable
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"variable\">~A</span>"
+ s)))
+ (:function
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"function\">~A</span>"
+ s)))
+ (:attribute
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"attribute\">~A</span>"
+ s)))
+ (:macro
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"macro\">~A</span>"
+ s)))
+ (:atom
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"atom\">~A</span>"
+ s)))
+ (:char
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ (:single-escape
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ (:paren-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((open nil)
+ (count 0))
+ (if (eql (length s) 1)
+ (progn
+ (when (member (elt s 0) (coerce *erlang-open-parens* 'list))
+ (setf open t)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter))
+ (when (member (elt s 0) (coerce *erlang-close-parens* 'list))
+ (setf open nil)
+ (decf paren-counter)
+ (setf count (mod paren-counter 6)))
+ (if open
+ (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
+ (1+ count) s *css-background-class*)
+ (format nil "</span>~A</span>"
+ s)))
+ s))))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *erlang-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ s)))
+ ))
+
+(defvar *python-reserved-words*
+ '("and" "assert" "break" "class" "continue"
+ "def" "del" "elif" "else" "except"
+ "exec" "finally" "for" "from" "global"
+ "if" "import" "in" "is" "lambda"
+ "not" "or" "pass" "print" "raise"
+ "return" "try" "while" "yield"))
+
+(define-coloring-type :python "Python"
+ :default-mode :normal
+ :transitions
+ ((:normal
+ ((or
+ (scan-any *c-open-parens*)
+ (scan-any *c-close-parens*))
+ (set-mode :paren-ish
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\#)
+ (set-mode :comment
+ :until (scan-any '(#\return #\newline))))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((scan "\"\"\"")
+ (set-mode :string
+ :until (scan "\"\"\"")))
+ ((scan "'''")
+ (set-mode :string
+ :until (scan "'''")))
+ ((scan #\')
+ (set-mode :string
+ :until (scan #\')))
+ ((scan "@")
+ (set-mode :decorator
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((scan "def")
+ (set-mode :def
+ :until (scan-any '(#\: #\())
+ :advancing nil))
+ ((scan "class")
+ (set-mode :def
+ :until (scan-any '(#\: #\())
+ :advancing nil))
+ ;; Python bug-fix from sjamaan of #scheme, 2010/06/26.
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (scan-any *c-terminators*)
+ :advancing nil)))
+ (:string
+ ((scan #\\)
+ (set-mode :single-escape
+ :until (advance 1)))))
+ :formatter-variables ((paren-counter 0))
+ :formatters
+ ((:normal
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ (:comment
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ (:string
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ (:character
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ (:single-escape
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ (:paren-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((open nil)
+ (count 0))
+ (if (eql (length s) 1)
+ (progn
+ (when (member (elt s 0) (coerce *c-open-parens* 'list))
+ (setf open t)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter))
+ (when (member (elt s 0) (coerce *c-close-parens* 'list))
+ (setf open nil)
+ (decf paren-counter)
+ (setf count (mod paren-counter 6)))
+ (if open
+ (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
+ (1+ count) s *css-background-class*)
+ (format nil "</span>~A</span>"
+ s)))
+ s))))
+ (:def
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"special\">~A</span><span
+class=\"keyword\">~A</span>"
+ (subseq s 0 (position #\Space s))
+ (subseq s (position #\Space s)))))
+ (:decorator
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"symbol\">~A</span>" s)))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *python-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>"
+ s)
+ s)))))
+
+(defvar *haskell-open-parens* "([{")
+
+(defvar *haskell-close-parens* ")]}")
+
+(defvar *haskell-in-word*
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
+
+(defvar *haskell-begin-id* "abcdefghijklmnopqrstuvwxyz")
+
+(defvar *haskell-begin-cons* "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+
+(defvar *haskell-in-symbol* "!#$%&*+./<=>?@\\^|-~:")
+
+(defvar *haskell-reserved-symbols*
+ '(".." "::" "@" "~" "=" "-&gt;" "&lt;-" "|" "\\"))
+
+(defvar *haskell-reserved-words*
+ '("case" "class" "data" "default" "deriving" "do" "else" "if"
+ "import" "in" "infix" "infixl" "infixr" "instance" "let" "module"
+ "newtype" "of" "then" "type" "where"))
+
+(defvar *haskell-non-constituent*
+ '(#\space #\return #\tab #\newline #\{ #\} #\( #\) #\" #\[ #\]))
+
+(define-coloring-type :haskell "Haskell"
+ :default-mode :normal
+ :transitions
+ (((:normal)
+ ((scan-any *haskell-in-word*)
+ (set-mode :identifier
+ :until (or (scan-any *haskell-non-constituent*)
+ (scan-any *haskell-in-symbol*))
+ :advancing nil))
+ ((scan "--")
+ (set-mode :comment
+ :until (scan-any '(#\return #\newline))
+ :advancing nil))
+ ((scan "{-")
+ (set-mode :multi-comment
+ :until (scan "-}")))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((scan #\`)
+ (set-mode :backquote
+ :until (scan #\`)))
+ ((scan "'")
+ (set-mode :char
+ :until (scan #\')))
+ ((scan-any *haskell-in-symbol*)
+ (set-mode :symbol
+ :until (or (scan-any *haskell-non-constituent*)
+ (scan-any *haskell-in-word*)
+ (scan #\'))
+ :advancing nil))
+ ((or (scan-any *haskell-open-parens*)
+ (scan-any *haskell-close-parens*))
+ (set-mode :parenlike
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\newline)
+ (set-mode :newline
+ :until (advance 1)
+ :advancing nil)))
+ ((:string)
+ ((scan #\\)
+ (set-mode :single-escape
+ :until (advance 1))))
+ ((:char)
+ ((scan #\\)
+ (set-mode :single-escape
+ :until (advance 1)))))
+ :formatter-variables
+ ((paren-counter 0)
+ (beginning-of-line t))
+ :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))
+ (cond (beginning-of-line
+ (setq beginning-of-line nil)
+ (if (and (> (length s) 0)
+ (char= (elt s 0) #\space))
+ (concatenate 'string "&nbsp;" (subseq s 1))
+ s))
+ (t s))))
+ ((:newline)
+ (lambda (type s)
+ (declare (ignore type))
+ (setq beginning-of-line t)
+ s))
+ ((:backquote)
+ (lambda (type s)
+ (declare (ignore type))
+ (setq beginning-of-line nil)
+ (if (find (elt s 1) *haskell-begin-cons*)
+ (format nil "<span class=\"variable\">~A</span>"
+ s)
+ (format nil "<span class=\"atom\">~A</span>"
+ s))))
+ ((:comment :multi-comment)
+ (lambda (type s)
+ (declare (ignore type))
+ (setq beginning-of-line nil)
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ ((:string)
+ (lambda (type s)
+ (declare (ignore type))
+ (setq beginning-of-line nil)
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ ((:char)
+ (lambda (type s)
+ (declare (ignore type))
+ (setq beginning-of-line nil)
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ ((:identifier)
+ (lambda (type s)
+ (declare (ignore type))
+ (prog1
+ (cond ((find (elt s 0) *haskell-begin-cons*)
+ (format nil "<span class=\"variable\">~A</span>" s))
+ ((member s *haskell-reserved-words* :test #'string=)
+ (format nil "<span class=\"keyword\">~A</span>" s))
+ (beginning-of-line
+ (format nil "<span class=\"function\">~A</span>" s))
+ (t s))
+ (setq beginning-of-line nil))))
+ ((:symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (setq beginning-of-line nil)
+ (cond ((member s *haskell-reserved-symbols* :test #'string=)
+ (format nil "<span class=\"keyword\">~A</span>" s))
+ ((char= (elt s 0) #\:)
+ (format nil "<span class=\"variable\">~A</span>" s))
+ (t (format nil "<span class=\"atom\">~A</span>" s)))))
+ ((:single-escape)
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ ((:parenlike)
+ (lambda (type s)
+ (declare (ignore type))
+ (setq beginning-of-line nil)
+ (let ((open nil)
+ (count 0))
+ (if (eql (length s) 1)
+ (progn
+ (when (find (elt s 0) *haskell-open-parens*)
+ (setf open t)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter))
+ (when (find (elt s 0) *haskell-close-parens*)
+ (setf open nil)
+ (decf paren-counter)
+ (setf count (mod paren-counter 6)))
+ (if open
+ (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
+ (1+ count) s *css-background-class*)
+ (format nil "</span>~A</span>"
+ s)))
+ s))))))
+
+(define-coloring-type :diff "Unified Context Diff"
+ :default-mode :first-char-on-line
+ :transitions
+ (((:first-char-on-line :normal :index :index-file :git-index :git-index-file :git-diff)
+ ((scan #\newline)
+ (set-mode :first-char-on-line)))
+ ((:first-char-on-line)
+ ((scan "@@")
+ (set-mode :range-information
+ :until (scan "@@")))
+ ((scan "===")
+ (set-mode :separator
+ :until (scan #\newline)))
+ ((scan "--- ")
+ (set-mode :file-from
+ :until (scan #\newline)))
+ ((scan "+++ ")
+ (set-mode :file-to
+ :until (scan #\newline)))
+ ((scan "diff --git ")
+ (set-mode :git-diff
+ :until (scan #\newline)))
+ ((scan "index ")
+ (set-mode :git-index))
+ ((scan "Index: ")
+ (set-mode :index))
+ ((scan #\-)
+ (set-mode :diff-deleted
+ :until (scan #\newline)))
+ ((scan #\+)
+ (set-mode :diff-added
+ :until (scan #\newline)))
+ ((advance 1)
+ (set-mode :normal)))
+ ((:git-diff)
+ ((scan "a/")
+ (set-mode :git-index-file))
+ ((scan "b/")
+ (set-mode :git-index-file)))
+ ((:git-index-file)
+ ((scan #\space)
+ (set-mode :git-diff)))
+ ((:index)
+ ((advance 1)
+ (set-mode :index-file))))
+ :formatters
+ (((:normal :first-char-on-line)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"diff-normal\">~A</span>" s)))
+ ((:separator :file-from :file-to)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>" s)))
+ ((:range-information)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"variable\">~A</span>" s)))
+ ((:diff-added)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"diff-added\">~A</span>" s)))
+ ((:diff-deleted)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"diff-deleted\">~A</span>" s)))
+ ((:index :git-index :git-diff)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"variable\">~A</span>" s)))
+ ((:index-file :git-index-file)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"symbol\">~A</span>" s)))))
+
+(defparameter *numbers* "0123456789")
+
+(define-coloring-type :webkit "WebKit (text or diff)"
+ :parent :diff
+ :transitions
+ (((:file-from)
+ ((scan "(revision ")
+ (set-mode :revision
+ :until (scan #\)))))
+ ((:revision)
+ ((scan-any *numbers*)
+ (set-mode :revision-number)))
+ ((:revision :revision-number)
+ ((scan #\newline)
+ (set-mode :first-char-on-line)))
+ ((:revision-number)
+ ((scan #\))
+ (set-mode :revision)))
+ ((:diff-added)
+ ((scan "Reviewed by NOBODY (OOPS!)")
+ (set-mode :oops
+ :until (advance 1)
+ :advancing nil))))
+ :formatters
+ (((:revision)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>" s)))
+ ((:revision-number)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<a href=\"http://trac.webkit.org/changeset/~A\" class=\"diff-link\">~:*~A</a>" s)))
+ ((:index-file)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<a href=\"http://trac.webkit.org/browser/trunk/~A\" class=\"diff-link\">~:*~A</a>"
+ s)))
+ ((:git-index-file)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<a href=\"http://trac.webkit.org/browser/trunk/~A\" class=\"diff-link\">~A</a>"
+ (if (> (length s) 2)
+ (subseq s 2)
+ s)
+ s)))
+ ((:oops)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"syntaxerror\">~A</span>" s)))))
View
22 colorize.lisp
@@ -7,8 +7,7 @@
(defparameter *version-token* (gensym)))
(defclass coloring-type ()
- ((modes :initarg :modes :accessor coloring-type-modes)
- (default-mode :initarg :default-mode :accessor coloring-type-default-mode)
+ ((default-mode :initarg :default-mode :accessor coloring-type-default-mode)
(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)
@@ -64,7 +63,7 @@
`(labels ((advance (,num)
(setf ,position-place (+ ,position-place ,num))
t)
- (scan-any (,items &key ,not-preceded-by)
+ (peek-any (,items &key ,not-preceded-by)
(incf *scan-calls*)
(let* ((,items (if (stringp ,items)
(coerce ,items 'list) ,items))
@@ -98,13 +97,16 @@
t)
t)
nil)
- (progn
- (advance (length ,item))
- t)
+ ,item
(progn
(and *reset-position*
(setf ,position-place *reset-position*))
nil)))))
+ (scan-any (,items &key ,not-preceded-by)
+ (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
+ (and ,item (advance (length ,item)))))
+ (peek (,item &key ,not-preceded-by)
+ (peek-any (list ,item) :not-preceded-by ,not-preceded-by))
(scan (,item &key ,not-preceded-by)
(scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
(macrolet ((set-mode (,new-mode &key ,until (,advancing t))
@@ -118,7 +120,7 @@
(defvar *formatter-local-variables*)
-(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
+(defmacro define-coloring-type (name fancy-name &key default-mode transitions formatters
autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
invisible)
(with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
@@ -128,7 +130,6 @@
(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
@@ -275,7 +276,8 @@
(error "No such coloring type: ~S" coloring-type)))
(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"
+ (format nil "<span class=\"~A\">~{~A~}~A</span>"
+ *css-background-class*
(mapcar color-formatter scan)
(funcall (coloring-type-formatter-after-hook coloring-type-object)))))
@@ -284,7 +286,7 @@
(mapcar #'(lambda (p)
(cons (car p)
(let ((tt
- (html-encode:encode-for-tt (cdr p))))
+ (html-encode:encode-for-pre (cdr p))))
(if (and (> (length tt) 0)
(char= (elt tt (1- (length tt))) #\>))
(format nil "~A~%" tt) tt))))
View
2  elisp-lookup.lisp
@@ -6,7 +6,7 @@
(defparameter *elisp-file*
(merge-pathnames "elisp-symbols.lisp-expr"
- #.*compile-file-pathname*))
+ (or #.*compile-file-truename* *default-pathname-defaults*)))
(defvar *table* nil)
View
2  r5rs-lookup.lisp
@@ -6,7 +6,7 @@
(defparameter *r5rs-file*
(merge-pathnames "r5rs-symbols.lisp-expr"
- #.*compile-file-pathname*))
+ (or #.*compile-file-truename* *default-pathname-defaults*)))
(defvar *table* nil)
Please sign in to comment.
Something went wrong with that request. Please try again.