summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-10-14 16:37:43 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-10-14 16:37:43 -0400
commit98c7a9c7a897d8a5f7a483aa15bf211c9769dad4 (patch)
tree106aa4e31f132174d78e175a25e5e3851a24c049 /src
parentcf62ed3325e024601d3d04d638b6a0aa383310ae (diff)
Syntax highlighting for embedded XML
Diffstat (limited to 'src')
-rw-r--r--src/elisp/urweb-mode.el76
-rw-r--r--src/urweb.grm37
-rw-r--r--src/urweb.lex5
3 files changed, 78 insertions, 40 deletions
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index d2cbfb3e..39cb41f8 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -160,24 +160,40 @@ See doc for the variable `urweb-mode-info'."
;; The font lock regular expressions.
-(defun inXml (depth)
- (and
- (re-search-backward "[<>{}]" nil t)
- (cond
- ((looking-at "{")
- (and (> depth 0)
- (inXml (- depth 1))))
- ((looking-at "}")
- (inXml (+ depth 1)))
- ((save-excursion (backward-char 1) (or (looking-at "=>") (looking-at "->")))
- (inXml depth))
- ((looking-at "<")
- nil)
- ((looking-at ">")
- (if (> depth 0)
- (and (re-search-backward "<" nil t)
- (inXml depth))
- (progn (backward-char 5) (not (looking-at "/html"))))))))
+(defun inXml ()
+ (save-excursion
+ (let (
+ (depth 0)
+ (finished nil)
+ (answer nil)
+ )
+ (while (and (not finished) (re-search-backward "[<>{}]" nil t))
+ (cond
+ ((looking-at "{")
+ (if (> depth 0)
+ (setq depth (- depth 1))
+ (setq finished t)))
+ ((looking-at "}")
+ (setq depth (+ depth 1)))
+ ((save-excursion (backward-char 1) (or (looking-at "=>") (looking-at "->")))
+ nil)
+ ((looking-at "<")
+ (setq finished t))
+ ((looking-at ">")
+ (if (> depth 0)
+ (if (not (re-search-backward "<" nil t))
+ (setq finished t))
+ (progn (backward-char 4)
+ (setq answer (not (or
+ (looking-at "/xml")
+ (looking-at "xml/"))))
+ (setq finished t))))))
+ answer)))
+
+(defun amAttribute (face)
+ (if (ignore-errors (save-excursion (backward-word 2) (backward-char 1) (looking-at "<")))
+ nil
+ face))
(defconst urweb-font-lock-keywords
`(;;(urweb-font-comments-and-strings)
@@ -187,25 +203,25 @@ See doc for the variable `urweb-mode-info'."
("\\(</\\sw+>\\)"
(1 font-lock-tag-face))
("\\([^<>{}]+\\)"
- (1 (if (save-excursion (inXml 0))
+ (1 (if (inXml)
font-lock-string-face
nil)))
("\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)\\s-+[^ \t\n=]"
(1 font-lock-keyword-face)
- (2 font-lock-function-name-face))
+ (2 (amAttribute font-lock-function-name-face)))
("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
- (3 font-lock-type-def-face))
+ (3 (amAttribute font-lock-type-def-face)))
("\\<\\(val\\|table\\|sequence\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
(1 font-lock-keyword-face)
- (3 font-lock-variable-name-face))
+ (3 (amAttribute font-lock-variable-name-face)))
("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
- (2 font-lock-module-def-face))
+ (2 (amAttribute font-lock-module-def-face)))
("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
- (2 font-lock-interface-def-face))
+ (2 (amAttribute font-lock-interface-def-face)))
(,urweb-keywords-regexp . font-lock-keyword-face)
(,urweb-sql-keywords-regexp . font-lock-sql-face)
@@ -336,12 +352,6 @@ See doc for the variable `urweb-mode-info'."
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . urweb-mode))
-;(mmm-add-classes
-; '((urweb-html
-; :submode html-mode
-; :front "<html>"
-; :back "</html>")))
-
;;;###autoload
(define-derived-mode urweb-mode fundamental-mode "Ur/Web"
"\\<urweb-mode-map>Major mode for editing Ur/Web code.
@@ -363,14 +373,10 @@ This mode runs `urweb-mode-hook' just before exiting.
;; For XEmacs
(easy-menu-add urweb-mode-menu)
-; (setq mmm-classes '(urweb-html))
-
;; Compatibility. FIXME: we should use `-' in Emacs-CVS.
(unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
- (urweb-mode-variables)
-; (mmm-mode-on)
- )
+ (urweb-mode-variables))
(defun urweb-mode-variables ()
(set-syntax-table urweb-mode-syntax-table)
diff --git a/src/urweb.grm b/src/urweb.grm
index 1879b241..8d5f8bb7 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -193,7 +193,7 @@ fun tagIn bt =
| INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
| CASE | IF | THEN | ELSE
- | XML_BEGIN of string | XML_END
+ | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
| NOTAGS of string
| BEGIN_TAG of string | END_TAG of string
@@ -801,10 +801,37 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
end)
| FOLD (EFold, s (FOLDleft, FOLDright))
- | XML_BEGIN xml XML_END (xml)
- | XML_BEGIN XML_END (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)),
- (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))),
- s (XML_BEGINleft, XML_ENDright))
+ | XML_BEGIN xml XML_END (let
+ val loc = s (XML_BEGINleft, XML_ENDright)
+ in
+ if XML_BEGIN = "xml" then
+ ()
+ else
+ ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
+ xml
+ end)
+ | XML_BEGIN XML_END (let
+ val loc = s (XML_BEGINleft, XML_ENDright)
+ in
+ if XML_BEGIN = "xml" then
+ ()
+ else
+ ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
+ (EApp ((EVar (["Basis"], "cdata"), loc),
+ (EPrim (Prim.String ""), loc)),
+ loc)
+ end)
+ | XML_BEGIN_END (let
+ val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright)
+ in
+ if XML_BEGIN_END = "xml" then
+ ()
+ else
+ ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
+ (EApp ((EVar (["Basis"], "cdata"), loc),
+ (EPrim (Prim.String ""), loc)),
+ loc)
+ end)
| LPAREN query RPAREN (query)
| LPAREN CWHERE sqlexp RPAREN (sqlexp)
diff --git a/src/urweb.lex b/src/urweb.lex
index 6f6bb63f..cd6cf66a 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -162,6 +162,11 @@ notags = [^<{\n]+;
continue ())
end);
+<INITIAL> "<" {id} "/>"=>(let
+ val tag = String.substring (yytext, 1, size yytext - 3)
+ in
+ Tokens.XML_BEGIN_END (tag, yypos, yypos + size yytext)
+ end);
<INITIAL> "<" {id} ">"=> (let
val tag = String.substring (yytext, 1, size yytext - 2)
in
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-13 19:43:05 +0000