Mercurial > urweb
changeset 119:7fdc146b2bc2
Proper handling of non-function-call links
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 13 Jul 2008 16:11:25 -0400 |
| parents | 7207f794b916 |
| children | 6230bdd122e7 |
| files | include/types.h lib/basis.lig src/cjr_print.sml src/tag.sml tests/links.lac tests/linksF.lac |
| diffstat | 6 files changed, 85 insertions(+), 13 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Sun Jul 13 15:47:18 2008 -0400 +++ b/include/types.h Sun Jul 13 16:11:25 2008 -0400 @@ -6,6 +6,8 @@ }; typedef struct __lws_0 lw_unit; +typedef lw_unit lw_Basis_unit; typedef struct lw_context *lw_context; +typedef lw_Basis_string lw_Basis_xhtml;
--- a/lib/basis.lig Sun Jul 13 15:47:18 2008 -0400 +++ b/lib/basis.lig Sun Jul 13 16:11:25 2008 -0400 @@ -2,6 +2,8 @@ type float type string +type unit = {} + con tag :: {Type} -> {Unit} -> {Unit} -> Type @@ -31,4 +33,7 @@ val i : tag [] [Body] [Body] val font : tag [Size = int, Face = string] [Body] [Body] +val h1 : tag [] [Body] [Body] +val li : tag [] [Body] [Body] + val a : tag [Link = xhtml] [Body] [Body]
--- a/src/cjr_print.sml Sun Jul 13 15:47:18 2008 -0400 +++ b/src/cjr_print.sml Sun Jul 13 16:11:25 2008 -0400 @@ -181,6 +181,8 @@ p_enamed env n, string "(ctx, lw_unit_v);", newline, + string "return;", + newline, string "}", newline]
--- a/src/tag.sml Sun Jul 13 15:47:18 2008 -0400 +++ b/src/tag.sml Sun Jul 13 16:11:25 2008 -0400 @@ -171,20 +171,35 @@ val (fnam, t, _, tag) = E.lookupENamed env f val (args, result) = unravel t - val (app, _) = foldl (fn (t, (app, n)) => - ((EApp (app, (ERel n, loc)), loc), - n - 1)) - ((ENamed f, loc), length args - 1) args - val body = (EWrite app, loc) val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) - val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => - ((EAbs ("x" ^ Int.toString n, - t, - rest, - abs), loc), - n + 1, - (TFun (t, rest), loc))) - (body, 0, unit) args + + val (abs, t) = + case args of + [] => + let + val body = (EWrite (ENamed f, loc), loc) + in + ((EAbs ("x", unit, unit, body), loc), + (TFun (unit, unit), loc)) + end + | _ => + let + val (app, _) = foldl (fn (t, (app, n)) => + ((EApp (app, (ERel n, loc)), loc), + n - 1)) + ((ENamed f, loc), length args - 1) args + val body = (EWrite app, loc) + val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => + ((EAbs ("x" ^ Int.toString n, + t, + rest, + abs), loc), + n + 1, + (TFun (t, rest), loc))) + (body, 0, unit) args + in + (abs, t) + end in [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc), (DExport cn, loc)]
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/links.lac Sun Jul 13 16:11:25 2008 -0400 @@ -0,0 +1,24 @@ +val pC : xhtml = <html><body> + <h1>Page C</h1> +</body></html> + +val pB : xhtml = <html><body> + <h1>Page B</h1> + + <li> <a link={pC}>C</a></li> +</body></html> + +val pA : xhtml = <html><body> + <h1>Page A</h1> + + <li> <a link={pB}>B</a></li> + <li> <a link={pC}>C</a></li> +</body></html> + +val main : unit -> xhtml = fn () => <html><body> + <h1>Main</h1> + + <li> <a link={pA}>A</a></li> + <li> <a link={pB}>B</a></li> + <li> <a link={pC}>C</a></li> +</body></html>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/linksF.lac Sun Jul 13 16:11:25 2008 -0400 @@ -0,0 +1,24 @@ +val pC : unit -> xhtml = fn () => <html><body> + <h1>Page C</h1> +</body></html> + +val pB : unit -> xhtml = fn () => <html><body> + <h1>Page B</h1> + + <li> <a link={pC ()}>C</a></li> +</body></html> + +val pA : unit -> xhtml = fn () => <html><body> + <h1>Page A</h1> + + <li> <a link={pB ()}>B</a></li> + <li> <a link={pC ()}>C</a></li> +</body></html> + +val main : unit -> xhtml = fn () => <html><body> + <h1>Main</h1> + + <li> <a link={pA ()}>A</a></li> + <li> <a link={pB ()}>B</a></li> + <li> <a link={pC ()}>C</a></li> +</body></html>