diff options
| -rw-r--r-- | lib/top.ur | 10 | ||||
| -rw-r--r-- | src/elisp/urweb-mode.el | 76 | ||||
| -rw-r--r-- | src/urweb.grm | 37 | ||||
| -rw-r--r-- | src/urweb.lex | 5 | ||||
| -rw-r--r-- | tests/crud.ur | 80 | ||||
| -rw-r--r-- | tests/crud1.ur | 16 |
6 files changed, 130 insertions, 94 deletions
@@ -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 = _} |