[Lisppaste-cvs] CVS lisppaste2

[bmastenbrook]

Update of /project/lisppaste/cvsroot/lisppaste2
In directory clnet:/tmp/cvs-serv29290

Modified Files:
	coloring-types.lisp 
Log Message:
Haskell syntax coloring (thanks to Kristof Bastiaensen!)


--- /project/lisppaste/cvsroot/lisppaste2/coloring-types.lisp	2006/08/14 21:34:02	1.20
+++ /project/lisppaste/cvsroot/lisppaste2/coloring-types.lisp	2006/09/05 18:33:47	1.21
@@ -788,4 +788,176 @@
       (if (member s *python-reserved-words* :test #'string=)
 	  (format nil "<span class=\"symbol\">~A</span>"
 		  s)
-	  s)))))
\ No newline at end of file
+	  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*
+  '(".." "::" "@" "~" "=" "->" "<-" "|" "\\"))
+
+(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"
+  :modes (:normal :comment :multi-comment :string :char :identifier
+                  :backquote :newline :symbol :parenlike :single-escape)
+  :default-mode :normal
+  :autodetect (lambda (text)
+                (search "haskell" text :test #'char-equal))
+  :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-any '(#\newline #\return))
+     (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 (char= (elt s 0) #\space)
+		 (concatenate 'string " " (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))))))
\ No newline at end of file