Syntax highlighting for embedded XML

6 files changed, 130 insertions, 94 deletions

diff --git a/lib/top.ur b/lib/top.ur
index d5a6140a..1b1d1ec5 100644
--- a/lib/top.ur
+++ b/lib/top.ur
@@ -74,7 +74,7 @@ fun foldTRX (tf :: Type -> Type) (ctx :: {Unit})
     foldTR [tf] [fn _ => xml ctx [] []]
            (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest] r acc =>
                <xml>{f [nm] [t] [rest] r}{acc}</xml>)
-           <xml></xml>
+           <xml/>
 
 fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit})
              (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
@@ -84,7 +84,7 @@ fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit})
             (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
                              [[nm] ~ rest] r acc =>
                 <xml>{f [nm] [t] [rest] r}{acc}</xml>)
-            <xml></xml>
+            <xml/>
 
 fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit})
              (f : nm :: Name -> t :: Type -> rest :: {Type}
@@ -94,7 +94,7 @@ fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit})
             (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest]
                              r1 r2 acc =>
                 <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
-            <xml></xml>
+            <xml/>
 
 fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
               (ctx :: {Unit})
@@ -105,7 +105,7 @@ fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
              (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
                               [[nm] ~ rest] r1 r2 acc =>
                  <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
-             <xml></xml>
+             <xml/>
 
 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
            (q : sql_query tables exps) [tables ~ exps]
@@ -114,7 +114,7 @@ fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
                 -> xml ctx [] []) =
     query q
           (fn fs acc => return <xml>{acc}{f fs}</xml>)
-          <xml></xml>
+          <xml/>
 
 fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type})
                 (q : sql_query tables exps) [tables ~ exps] =
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
diff --git a/tests/crud.ur b/tests/crud.ur
index 6479da19..32233eb0 100644
--- a/tests/crud.ur
+++ b/tests/crud.ur
@@ -28,74 +28,74 @@ fun create (inputs : $(mapT2T sndTT M.cols)) =
         () <- dml (insert tab (foldT2R2 [sndTT] [colMeta]
                 [fn cols => $(mapT2T (fn t :: (Type * Type) =>
                         sql_exp [] [] [] t.1) cols)]
-                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) =>
-                        [[nm] ~ rest] =>
-                        fn input col acc => acc with nm = sql_inject col.Inject (col.Parse input))
+                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                 [[nm] ~ rest] =>
+                 fn input col acc => acc with nm = sql_inject col.Inject (col.Parse input))
                 {} [M.cols] inputs M.cols
                 with #Id = (SQL {id})));
-        return <html><body>
+        return <xml><body>
                 Inserted with ID {txt _ id}.
-        </body></html>
+        </body></xml>
 
 fun save (id : int) (inputs : $(mapT2T sndTT M.cols)) =
         () <- dml (update [mapT2T fstTT M.cols] (foldT2R2 [sndTT] [colMeta]
                 [fn cols => $(mapT2T (fn t :: (Type * Type) =>
                         sql_exp [T = [Id = int] ++ mapT2T fstTT M.cols] [] [] t.1) cols)]
-                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) =>
-                        [[nm] ~ rest] =>
-                        fn input col acc => acc with nm = sql_inject col.Inject (col.Parse input))
+                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                 [[nm] ~ rest] =>
+                 fn input col acc => acc with nm = sql_inject col.Inject (col.Parse input))
                 {} [M.cols] inputs M.cols)
                 tab (WHERE T.Id = {id}));
-        return <html><body>
+        return <xml><body>
                 Saved!
-        </body></html>
+        </body></xml>
 
 fun update (id : int) =
         fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id});
         case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of
-          None => return <html><body>Not found!</body></html>
-        | Some fs => return <html><body><lform>
+          None => return <xml><body>Not found!</body></xml>
+        | Some fs => return <xml><body><lform>
                 {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)]
-                        (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) =>
-                                [[nm] ~ rest] =>
-                                fn (v : t.1) (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <lform>
-                                        <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
-                                        {useMore acc}
-                                </lform>)
-                        <lform></lform>
+                        (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                         [[nm] ~ rest] (v : t.1) (col : colMeta t)
+                                         (acc : xml form [] (mapT2T sndTT rest)) =>
+                            <xml>
+                              <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
+                              {useMore acc}
+                            </xml>)
+                        <xml/>
                         [M.cols] fs.Tab M.cols}
 
                 <submit action={save id}/>
-        </lform></body></html>
+        </lform></body></xml>
 
 fun delete (id : int) =
         () <- dml (DELETE FROM tab WHERE Id = {id});
-        return <html><body>
+        return <xml><body>
                 The deed is done.
-        </body></html>
+        </body></xml>
 
-fun confirm (id : int) = return <html><body>
+fun confirm (id : int) = return <xml><body>
         <p>Are you sure you want to delete ID #{txt _ id}?</p>
  
         <p><a link={delete id}>I was born sure!</a></p>
-</body></html>
+</body></xml>
 
 fun main () =
         rows <- queryX (SELECT * FROM tab AS T)
-                (fn (fs : {T : $([Id = int] ++ mapT2T fstTT M.cols)}) => <body>
+                (fn (fs : {T : $([Id = int] ++ mapT2T fstTT M.cols)}) => <xml>
                         <tr>
                                 <td>{txt _ fs.T.Id}</td>
                                 {foldT2RX2 [fstTT] [colMeta] [tr]
-                                        (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) =>
-                                                [[nm] ~ rest] =>
-                                                fn v col => <tr>
+                                        (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                                [[nm] ~ rest] v col => <xml>
                                                         <td>{col.Show v}</td>
-                                                </tr>)
+                                                </xml>)
                                         [M.cols] (fs.T -- #Id) M.cols}
                                 <td><a link={update fs.T.Id}>[Update]</a> <a link={confirm fs.T.Id}>[Delete]</a></td>
                         </tr>
-                </body>);
-        return <html><head>
+                </xml>);
+        return <xml><head>
                 <title>{cdata M.title}</title>
 
                 </head><body>
@@ -106,11 +106,10 @@ fun main () =
                 <tr>
                         <th>ID</th>
                         {foldT2RX [colMeta] [tr]
-                                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) =>
-                                        [[nm] ~ rest] =>
-                                        fn col => <tr>
+                                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                        [[nm] ~ rest] col => <xml>
                                                 <th>{cdata col.Nam}</th>
-                                        </tr>)
+                                        </xml>)
                                 [M.cols] M.cols}
                 </tr>
                 {rows}
@@ -120,17 +119,16 @@ fun main () =
 
                 <lform>
                         {foldT2R [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)]
-                                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) =>
-                                        [[nm] ~ rest] =>
-                                        fn (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <lform>
+                                (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                        [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <xml>
                                                 <li> {cdata col.Nam}: {col.Widget [nm]}</li>
                                                 {useMore acc}
-                                        </lform>)
-                                <lform></lform>
+                                        </xml>)
+                                <xml/>
                                 [M.cols] M.cols}
 
                         <submit action={create}/>
                 </lform>
-        </body></html>
+        </body></xml>
 
 end
diff --git a/tests/crud1.ur b/tests/crud1.ur
index 2ed2b9e7..80b2b103 100644
--- a/tests/crud1.ur
+++ b/tests/crud1.ur
@@ -2,33 +2,33 @@ table t1 : {Id : int, A : int, B : string, C : float, D : bool}
 
 val a = {Nam = "A",
          Show = txt _,
-         Widget = fn nm :: Name => <lform><textbox{nm}/></lform>,
+         Widget = fn nm :: Name => <xml><textbox{nm}/></xml>,
          WidgetPopulated = fn (nm :: Name) n =>
-                              <lform><textbox{nm} value={show _ n}/></lform>,
+                              <xml><textbox{nm} value={show _ n}/></xml>,
          Parse = readError _,
          Inject = _}
 
 val b = {Nam = "B",
          Show = txt _,
-         Widget = fn nm :: Name => <lform><textbox{nm}/></lform>,
+         Widget = fn nm :: Name => <xml><textbox{nm}/></xml>,
          WidgetPopulated = fn (nm :: Name) s =>
-                              <lform><textbox{nm} value={s}/></lform>,
+                              <xml><textbox{nm} value={s}/></xml>,
          Parse = readError _,
          Inject = _}
 
 val c = {Nam = "C",
          Show = txt _,
-         Widget = fn nm :: Name => <lform><textbox{nm}/></lform>,
+         Widget = fn nm :: Name => <xml><textbox{nm}/></xml>,
          WidgetPopulated = fn (nm :: Name) n =>
-                              <lform><textbox{nm} value={show _ n}/></lform>,
+                              <xml><textbox{nm} value={show _ n}/></xml>,
          Parse = readError _,
          Inject = _}
 
 val d = {Nam = "D",
          Show = txt _,
-         Widget = fn nm :: Name => <lform><checkbox{nm}/></lform>,
+         Widget = fn nm :: Name => <xml><checkbox{nm}/></xml>,
          WidgetPopulated = fn (nm :: Name) b =>
-                              <lform><checkbox{nm} checked={b}/></lform>,
+                              <xml><checkbox{nm} checked={b}/></xml>,
          Parse = fn x => x,
          Inject = _}