Mercurial > urweb
changeset 369:226c977faa9c
Crud indented properly, except for <xml>...</xml> outside parens and sig/struct
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 16 Oct 2008 14:40:28 -0400 |
| parents | b6be16792584 |
| children | 4f75cc2e1373 |
| files | src/elisp/urweb-mode.el src/elisp/urweb-move.el tests/crud.ur |
| diffstat | 3 files changed, 104 insertions(+), 104 deletions(-) [+] |
line wrap: on
line diff
--- a/src/elisp/urweb-mode.el Thu Oct 16 14:17:55 2008 -0400 +++ b/src/elisp/urweb-mode.el Thu Oct 16 14:40:28 2008 -0400 @@ -452,33 +452,17 @@ (1+ (current-column)) nil)))) -(defun urweb-begun-xml () - "Check if this is the first new line in a new <xml>...</xml> section" +(defun urweb-empty-line () (save-excursion + (beginning-of-line) (let ((start-pos (point))) - (previous-line 1) - (search-forward "<xml>" start-pos t)))) + (end-of-line) + (not (re-search-backward "[^\n \t]" start-pos t))))) -(defun urweb-new-tags () - "Decide if the previous line of XML introduced unclosed tags" - (save-excursion - (let ((start-pos (point)) - (depth 0) - (done nil)) - (previous-line 1) - (beginning-of-line) - (while (and (not done) (search-forward "<" start-pos t)) - (if (looking-at "/") - (if (search-forward ">" start-pos t) - (when (> depth 0) (decf depth)) - (setq done t)) - (if (search-forward ">" start-pos t) - (if (not (save-excursion (backward-char 2) (looking-at "/"))) - (incf depth)) - (setq done t)))) - (and (not done) (> depth 0))))) +(defun urweb-seek-back () + (while (urweb-empty-line) (previous-line 1))) -(defun skip-matching-braces () +(defun urweb-skip-matching-braces () "Skip backwards past matching brace pairs, to calculate XML indentation after quoted Ur code" (beginning-of-line) (let ((start-pos (point)) @@ -497,13 +481,36 @@ ((looking-at "{") (decf depth))))))) +(defun urweb-new-tags () + "Decide if the previous line of XML introduced unclosed tags" + (save-excursion + (let ((start-pos (point)) + (depth 0) + (done nil)) + (previous-line 1) + (urweb-seek-back) + (urweb-skip-matching-braces) + (urweb-seek-back) + (beginning-of-line) + (while (and (not done) (search-forward "<" start-pos t)) + (if (looking-at "/") + (if (search-forward ">" start-pos t) + (when (> depth 0) (decf depth)) + (setq done t)) + (if (search-forward ">" start-pos t) + (if (not (save-excursion (backward-char 2) (looking-at "/"))) + (incf depth)) + (setq done t)))) + (and (not done) (> depth 0))))) + (defun urweb-tag-matching-indent () "Seek back to a matching opener tag and get its line's indent" (save-excursion + (end-of-line) + (search-backward "</" nil t) (urweb-tag-matcher) - (if (looking-at "<xml") - (+ (current-indentation) 2) - (current-indentation)))) + (beginning-of-line) + (current-indentation))) (defun urweb-calculate-indentation () (save-excursion @@ -527,14 +534,13 @@ (and (urweb-in-xml) (let ((prev-indent (save-excursion (previous-line 1) - (skip-matching-braces) - (re-search-backward "^[^\n]" nil t) + (urweb-seek-back) + (urweb-skip-matching-braces) + (urweb-seek-back) (current-indentation)))) (cond ((looking-at "</") (urweb-tag-matching-indent)) - ((urweb-begun-xml) - (+ prev-indent 4)) ((urweb-new-tags) (+ prev-indent 2)) (t
--- a/src/elisp/urweb-move.el Thu Oct 16 14:17:55 2008 -0400 +++ b/src/elisp/urweb-move.el Thu Oct 16 14:40:28 2008 -0400 @@ -75,7 +75,7 @@ (("AND" "OR") . 1) ((">=" "<>" "<=" "=") . 4) (("+" "-" "^") . 6) - (("/" "*" "%") . 7) + (("*" "%") . 7) (("NOT") 9))) "Alist of Ur/Web infix operators and their precedence.") @@ -250,12 +250,6 @@ (op-prec (urweb-op-prec op 'back)) match) (cond - ((save-excursion (backward-char 5) - (looking-at "</xml>")) - (backward-char 6) - (urweb-tag-matcher) - (backward-char 1) - (urweb-backward-sexp prec)) ((not op) (let ((point (point))) (ignore-errors (let ((forward-sexp-function nil)) (backward-sexp 1))) @@ -278,11 +272,6 @@ ;; this reproduces the usual backward-sexp, but it might be bogus ;; in this case since !@$% is a perfectly fine symbol (t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec)) -;; (when (save-excursion (backward-char 5) (looking-at "</xml>")) -;; (backward-char 5) -;; (urweb-tag-matcher) -;; (backward-char) -;; (urweb-backward-sexp prec))) (defun urweb-forward-sexp (prec) "Moves one sexp forward if possible, or one char else.
--- a/tests/crud.ur Thu Oct 16 14:17:55 2008 -0400 +++ b/tests/crud.ur Thu Oct 16 14:40:28 2008 -0400 @@ -1,11 +1,11 @@ con colMeta = fn t_formT :: (Type * Type) => { - Nam : string, - Show : t_formT.1 -> xbody, - Widget : nm :: Name -> xml form [] [nm = t_formT.2], - WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2], - Parse : t_formT.2 -> t_formT.1, - Inject : sql_injectable t_formT.1 -} + Nam : string, + Show : t_formT.1 -> xbody, + Widget : nm :: Name -> xml form [] [nm = t_formT.2], + WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2], + Parse : t_formT.2 -> t_formT.1, + Inject : sql_injectable t_formT.1 + } con colsMeta = fn cols :: {(Type * Type)} => $(Top.mapT2T colMeta cols) fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t) @@ -15,7 +15,7 @@ Widget = fn nm :: Name => (<xml><textbox{nm}/></xml>), WidgetPopulated = fn (nm :: Name) n => (<xml><textbox{nm} value={show _ n}/></xml>), - Parse = readError _,e + Parse = readError _, Inject = _} val int = default _ _ _ @@ -31,14 +31,14 @@ Inject = _} functor Make(M : sig - con cols :: {(Type * Type)} - constraint [Id] ~ cols - val tab : sql_table ([Id = int] ++ mapT2T fstTT cols) +con cols :: {(Type * Type)} +constraint [Id] ~ cols +val tab : sql_table ([Id = int] ++ mapT2T fstTT cols) - val title : string +val title : string - val cols : colsMeta cols -end) = struct +val cols : colsMeta cols + end) = struct open constraints M val tab = M.tab @@ -64,10 +64,13 @@ () <- 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)] + 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 input col acc => acc with nm = + sql_inject col.Inject (col.Parse input)) {} [M.cols] inputs M.cols) tab (WHERE T.Id = {id})); return <xml><body> @@ -79,18 +82,18 @@ case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of None => return <xml><body>Not found!</body></xml> | Some fs => return <xml><body><form> - {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] - (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} + {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] + (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}/> + <submit action={save id}/> </form></body></xml> fun delete (id : int) = @@ -100,59 +103,61 @@ </body></xml> fun confirm (id : int) = return <xml><body> - <p>Are you sure you want to delete ID #{txt _ id}?</p> + <p>Are you sure you want to delete ID #{txt _ id}?</p> - <p><a link={delete id}>I was born sure!</a></p> + <p><a link={delete id}>I was born sure!</a></p> </body></xml> fun main () = rows <- queryX (SELECT * FROM tab AS T) (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] v col => <xml> - <td>{col.Show v}</td> - </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> - </xml>); + <tr> + <td>{txt _ fs.T.Id}</td> + {foldT2RX2 [fstTT] [colMeta] [tr] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] v col => <xml> + <td>{col.Show v}</td> + </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> + </xml>); return <xml><head> <title>{cdata M.title}</title> - </head><body> - <h1>{cdata M.title}</h1> + <h1>{cdata M.title}</h1> - <table border={1}> - <tr> - <th>ID</th> - {foldT2RX [colMeta] [tr] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] col => <xml> + <table border={1}> + <tr> + <th>ID</th> + {foldT2RX [colMeta] [tr] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] col => <xml> <th>{cdata col.Nam}</th> </xml>) - [M.cols] M.cols} - </tr> - {rows} - </table> + [M.cols] M.cols} + </tr> + {rows} + </table> - <br/> + <br/> - <form> - {foldT2R [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <xml> + <form> + {foldT2R [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] + (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} </xml>) - <xml/> - [M.cols] M.cols} - - <submit action={create}/> - </form> + <xml/> + [M.cols] M.cols} + + <submit action={create}/> + </form> </body></xml> end