diff options
| -rw-r--r-- | include/types.h | 2 | ||||
| -rw-r--r-- | lib/basis.lig | 5 | ||||
| -rw-r--r-- | src/cjr_print.sml | 2 | ||||
| -rw-r--r-- | src/tag.sml | 41 | ||||
| -rw-r--r-- | tests/links.lac | 24 | ||||
| -rw-r--r-- | tests/linksF.lac | 24 |
6 files changed, 85 insertions, 13 deletions
diff --git a/include/types.h b/include/types.h index 2dfaad84..083f478a 100644 --- a/include/types.h +++ b/include/types.h @@ -6,6 +6,8 @@ struct __lws_0 { }; 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; diff --git a/lib/basis.lig b/lib/basis.lig index dcf1713d..189b0350 100644 --- a/lib/basis.lig +++ b/lib/basis.lig @@ -2,6 +2,8 @@ type int type float type string +type unit = {} + con tag :: {Type} -> {Unit} -> {Unit} -> Type @@ -31,4 +33,7 @@ val b : tag [] [Body] [Body] 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] diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 980be593..b037137e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -181,6 +181,8 @@ fun p_page env (s, n) = p_enamed env n, string "(ctx, lw_unit_v);", newline, + string "return;", + newline, string "}", newline] diff --git a/src/tag.sml b/src/tag.sml index 9004a55b..e451281a 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -171,20 +171,35 @@ fun tag file = 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)] diff --git a/tests/links.lac b/tests/links.lac new file mode 100644 index 00000000..7a7b1e98 --- /dev/null +++ b/tests/links.lac @@ -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> diff --git a/tests/linksF.lac b/tests/linksF.lac new file mode 100644 index 00000000..0bcfe1d1 --- /dev/null +++ b/tests/linksF.lac @@ -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> |