Mercurial > urweb
changeset 186:88d46972de53
bool in Basis
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 03 Aug 2008 18:53:20 -0400 |
| parents | 19ee24bffbc0 |
| children | fb6ed259f5bd |
| files | include/lacweb.h include/types.h lib/basis.lig src/c/lacweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/compiler.sml src/core.sml src/core_print.sml src/corify.sml src/elab_env.sml src/mono.sml src/mono_print.sml src/monoize.sml tests/bool.lac |
| diffstat | 16 files changed, 197 insertions(+), 87 deletions(-) [+] |
line wrap: on
line diff
--- a/include/lacweb.h Sun Aug 03 17:57:47 2008 -0400 +++ b/include/lacweb.h Sun Aug 03 18:53:20 2008 -0400 @@ -40,13 +40,16 @@ char *lw_Basis_urlifyInt(lw_context, lw_Basis_int); char *lw_Basis_urlifyFloat(lw_context, lw_Basis_float); char *lw_Basis_urlifyString(lw_context, lw_Basis_string); +char *lw_Basis_urlifyBool(lw_context, lw_Basis_bool); void lw_Basis_urlifyInt_w(lw_context, lw_Basis_int); void lw_Basis_urlifyFloat_w(lw_context, lw_Basis_float); void lw_Basis_urlifyString_w(lw_context, lw_Basis_string); +void lw_Basis_urlifyBool_w(lw_context, lw_Basis_bool); -lw_Basis_int lw_unurlifyInt(char **); -lw_Basis_float lw_unurlifyFloat(char **); -lw_Basis_string lw_unurlifyString(lw_context, char **); +lw_Basis_int lw_Basis_unurlifyInt(lw_context, char **); +lw_Basis_float lw_Basis_unurlifyFloat(lw_context, char **); +lw_Basis_string lw_Basis_unurlifyString(lw_context, char **); +lw_Basis_bool lw_Basis_unurlifyBool(lw_context, char **); lw_Basis_string lw_Basis_strcat(lw_context, lw_Basis_string, lw_Basis_string);
--- a/include/types.h Sun Aug 03 17:57:47 2008 -0400 +++ b/include/types.h Sun Aug 03 18:53:20 2008 -0400 @@ -8,6 +8,12 @@ typedef struct __lws_0 lw_unit; typedef lw_unit lw_Basis_unit; +enum lw_Basis_bool_enum { lw_Basis_False, lw_Basis_True }; + +typedef struct lw_Basis_bool { + enum lw_Basis_bool_enum tag; +} *lw_Basis_bool; + typedef struct lw_context *lw_context; typedef lw_Basis_string lw_Basis_xhtml;
--- a/lib/basis.lig Sun Aug 03 17:57:47 2008 -0400 +++ b/lib/basis.lig Sun Aug 03 18:53:20 2008 -0400 @@ -4,6 +4,8 @@ type unit = {} +datatype bool = False | True + con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type
--- a/src/c/lacweb.c Sun Aug 03 17:57:47 2008 -0400 +++ b/src/c/lacweb.c Sun Aug 03 18:53:20 2008 -0400 @@ -338,6 +338,13 @@ return r; } +char *lw_Basis_urlifyBool(lw_context ctx, lw_Basis_bool b) { + if (b->tag == lw_Basis_False) + return "0"; + else + return "1"; +} + static void lw_Basis_urlifyInt_w_unsafe(lw_context ctx, lw_Basis_int n) { int len; @@ -375,6 +382,13 @@ } } +void lw_Basis_urlifyBool_w(lw_context ctx, lw_Basis_bool b) { + if (b->tag == lw_Basis_False) + lw_writec(ctx, '0'); + else + lw_writec(ctx, '1'); +} + static char *lw_unurlify_advance(char *s) { char *new_s = strchr(s, '/'); @@ -387,7 +401,7 @@ return new_s; } -lw_Basis_int lw_unurlifyInt(char **s) { +lw_Basis_int lw_Basis_unurlifyInt(lw_context ctx, char **s) { char *new_s = lw_unurlify_advance(*s); int r; @@ -396,7 +410,7 @@ return r; } -lw_Basis_float lw_unurlifyFloat(char **s) { +lw_Basis_float lw_Basis_unurlifyFloat(lw_context ctx, char **s) { char *new_s = lw_unurlify_advance(*s); int r; @@ -434,7 +448,23 @@ return s1; } -lw_Basis_string lw_unurlifyString(lw_context ctx, char **s) { +static struct lw_Basis_bool lw_False = { lw_Basis_False }, + lw_True = { lw_Basis_True }; + +lw_Basis_bool lw_Basis_unurlifyBool(lw_context ctx, char **s) { + char *new_s = lw_unurlify_advance(*s); + lw_Basis_bool r; + + if (*s[0] == 0 || !strcmp(*s, "0") || !strcmp(*s, "off")) + r = &lw_False; + else + r = &lw_True; + + *s = new_s; + return r; +} + +lw_Basis_string lw_Basis_unurlifyString(lw_context ctx, char **s) { char *new_s = lw_unurlify_advance(*s); char *r, *s1, *s2; int len, n;
--- a/src/cjr.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/cjr.sml Sun Aug 03 18:53:20 2008 -0400 @@ -40,7 +40,7 @@ datatype patCon = PConVar of int - | PConFfi of {mod : string, datatyp : string, con : string} + | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} datatype pat' = PWild
--- a/src/cjr_print.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/cjr_print.sml Sun Aug 03 18:53:20 2008 -0400 @@ -116,7 +116,7 @@ fun p_patCon env pc = case pc of PConVar n => p_con_named env n - | PConFfi _ => raise Fail "CjrPrint PConFfi" + | PConFfi {mod = m, con, ...} => string ("lw_" ^ m ^ "_" ^ con) fun p_pat (env, exit, depth) (p, _) = case p of @@ -276,7 +276,7 @@ ("__lwd_" ^ dx ^ "_" ^ Int.toString dn, "__lwc_" ^ x ^ "_" ^ Int.toString n) end - | PConFfi {mod = m, datatyp, con} => + | PConFfi {mod = m, datatyp, con, ...} => ("lw_" ^ m ^ "_" ^ datatyp, "lw_" ^ m ^ "_" ^ con) @@ -706,11 +706,15 @@ string "}"] end + fun capitalize s = + if s = "" then + "" + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + fun unurlify (t, loc) = case t of - TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)" - | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)" - | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)" + TFfi (m, t) => string ("lw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") | TRecord 0 => string "lw_unit_v" | TRecord i =>
--- a/src/cjrize.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/cjrize.sml Sun Aug 03 18:53:20 2008 -0400 @@ -103,10 +103,23 @@ val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan) -fun cifyPatCon pc = +fun cifyPatCon (pc, sm) = case pc of - L.PConVar n => L'.PConVar n - | L.PConFfi mx => L'.PConFfi mx + L.PConVar n => (L'.PConVar n, sm) + | L.PConFfi {mod = m, datatyp, con, arg} => + let + val (arg, sm) = + case arg of + NONE => (NONE, sm) + | SOME t => + let + val (t, sm) = cifyTyp (t, sm) + in + (SOME t, sm) + end + in + (L'.PConFfi {mod = m, datatyp = datatyp, con = con, arg = arg}, sm) + end fun cifyPat ((p, loc), sm) = case p of @@ -118,12 +131,18 @@ ((L'.PVar (x, t), loc), sm) end | L.PPrim p => ((L'.PPrim p, loc), sm) - | L.PCon (pc, NONE) => ((L'.PCon (cifyPatCon pc, NONE), loc), sm) + | L.PCon (pc, NONE) => + let + val (pc, sm) = cifyPatCon (pc, sm) + in + ((L'.PCon (pc, NONE), loc), sm) + end | L.PCon (pc, SOME p) => let + val (pc, sm) = cifyPatCon (pc, sm) val (p, sm) = cifyPat (p, sm) in - ((L'.PCon (cifyPatCon pc, SOME p), loc), sm) + ((L'.PCon (pc, SOME p), loc), sm) end | L.PRecord xps => let @@ -154,8 +173,9 @@ in (SOME e, sm) end + val (pc, sm) = cifyPatCon (pc, sm) in - ((L'.ECon (cifyPatCon pc, eo), loc), sm) + ((L'.ECon (pc, eo), loc), sm) end | L.EFfi mx => ((L'.EFfi mx, loc), sm) | L.EFfiApp (m, x, es) =>
--- a/src/compiler.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/compiler.sml Sun Aug 03 18:53:20 2008 -0400 @@ -430,7 +430,7 @@ if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" else if not (OS.Process.isSuccess (OS.Process.system link)) then - print "C linking failed\n" + print "C linking failed\n" else print "Success\n" end @@ -439,18 +439,21 @@ case cjrize job of NONE => print "Laconic compilation failed\n" | SOME file => - let - val cname = "/tmp/lacweb.c" - val oname = "/tmp/lacweb.o" - val ename = "/tmp/webapp" + if ErrorMsg.anyErrors () then + print "Laconic compilation failed\n" + else + let + val cname = "/tmp/lacweb.c" + val oname = "/tmp/lacweb.o" + val ename = "/tmp/webapp" - val outf = TextIO.openOut cname - val s = TextIOPP.openOut {dst = outf, wid = 80} - in - Print.fprint s (CjrPrint.p_file CjrEnv.empty file); - TextIO.closeOut outf; + val outf = TextIO.openOut cname + val s = TextIOPP.openOut {dst = outf, wid = 80} + in + Print.fprint s (CjrPrint.p_file CjrEnv.empty file); + TextIO.closeOut outf; - compileC {cname = cname, oname = oname, ename = ename} - end + compileC {cname = cname, oname = oname, ename = ename} + end end
--- a/src/core.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/core.sml Sun Aug 03 18:53:20 2008 -0400 @@ -61,7 +61,7 @@ datatype patCon = PConVar of int - | PConFfi of {mod : string, datatyp : string, con : string} + | PConFfi of {mod : string, datatyp : string, con : string, arg : con option} datatype pat' = PWild
--- a/src/core_print.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/core_print.sml Sun Aug 03 18:53:20 2008 -0400 @@ -162,7 +162,7 @@ fun p_patCon env pc = case pc of PConVar n => p_con_named env n - | PConFfi {mod = m, con, ...} => box [string "FFI(", + | PConFfi {mod = m, con, ...} => box [string "FFIC(", string m, string ".", string con,
--- a/src/corify.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/corify.sml Sun Aug 03 18:53:20 2008 -0400 @@ -62,7 +62,7 @@ val enter : t -> t val leave : t -> {outer : t, inner : t} - val ffi : string -> L'.con SM.map -> string SM.map -> t + val ffi : string -> L'.con SM.map -> (string * L'.con option) SM.map -> t datatype core_con = CNormal of int @@ -72,6 +72,7 @@ val lookupConByName : t -> string -> core_con val bindConstructor : t -> string -> int -> L'.patCon -> t + val lookupConstructorByNameOpt : t -> string -> L'.patCon option val lookupConstructorByName : t -> string -> L'.patCon val lookupConstructorById : t -> int -> L'.patCon @@ -100,7 +101,7 @@ funs : (string * int * L.str) SM.map} | FFfi of {mod : string, vals : L'.con SM.map, - constructors : string SM.map} + constructors : (string * L'.con option) SM.map} type t = { cons : int IM.map, @@ -257,12 +258,23 @@ NONE => raise Fail "Corify.St.lookupConstructorById" | SOME x => x +fun lookupConstructorByNameOpt ({current, ...} : t) x = + case current of + FFfi {mod = m, constructors, ...} => + (case SM.find (constructors, x) of + NONE => NONE + | SOME (n, to) => SOME (L'.PConFfi {mod = m, datatyp = n, con = x, arg = to})) + | FNormal {constructors, ...} => + case SM.find (constructors, x) of + NONE => NONE + | SOME n => SOME n + fun lookupConstructorByName ({current, ...} : t) x = case current of FFfi {mod = m, constructors, ...} => (case SM.find (constructors, x) of NONE => raise Fail "Corify.St.lookupConstructorByName [1]" - | SOME n => L'.PConFfi {mod = m, datatyp = n, con = x}) + | SOME (n, to) => L'.PConFfi {mod = m, datatyp = n, con = x, arg = to}) | FNormal {constructors, ...} => case SM.find (constructors, x) of NONE => raise Fail "Corify.St.lookupConstructorByName [2]" @@ -433,36 +445,43 @@ val st = St.lookupStrById st m val st = foldl St.lookupStrByName st ms in - case St.lookupValByName st x of - St.ENormal n => (L'.ENamed n, loc) - | St.EFfi (m, t) => - case t of - (L'.TFun (dom as (L'.TRecord (L'.CRecord (_, []), _), _), ran), _) => - (L'.EAbs ("arg", dom, ran, (L'.EFfiApp (m, x, []), loc)), loc) - | t as (L'.TFun _, _) => - let - fun getArgs (all as (t, _), args) = - case t of - L'.TFun (dom, ran) => getArgs (ran, dom :: args) - | _ => (all, rev args) - - val (result, args) = getArgs (t, []) + case St.lookupConstructorByNameOpt st x of + SOME (pc as L'.PConFfi {mod = m, datatyp, arg, ...}) => + (case arg of + NONE => (L'.ECon (pc, NONE), loc) + | SOME dom => (L'.EAbs ("x", dom, (L'.CFfi (m, datatyp), loc), + (L'.ECon (pc, SOME (L'.ERel 0, loc)), loc)), loc)) + | _ => + case St.lookupValByName st x of + St.ENormal n => (L'.ENamed n, loc) + | St.EFfi (m, t) => + case t of + (L'.TFun (dom as (L'.TRecord (L'.CRecord (_, []), _), _), ran), _) => + (L'.EAbs ("arg", dom, ran, (L'.EFfiApp (m, x, []), loc)), loc) + | t as (L'.TFun _, _) => + let + fun getArgs (all as (t, _), args) = + case t of + L'.TFun (dom, ran) => getArgs (ran, dom :: args) + | _ => (all, rev args) + + val (result, args) = getArgs (t, []) - val (actuals, _) = foldr (fn (_, (actuals, n)) => - ((L'.ERel n, loc) :: actuals, - n + 1)) ([], 0) args - val app = (L'.EFfiApp (m, x, actuals), loc) - val (abs, _, _) = foldr (fn (t, (abs, ran, n)) => - ((L'.EAbs ("arg" ^ Int.toString n, - t, - ran, - abs), loc), - (L'.TFun (t, ran), loc), - n - 1)) (app, result, length args - 1) args - in - abs - end - | _ => (L'.EFfi (m, x), loc) + val (actuals, _) = foldr (fn (_, (actuals, n)) => + ((L'.ERel n, loc) :: actuals, + n + 1)) ([], 0) args + val app = (L'.EFfiApp (m, x, actuals), loc) + val (abs, _, _) = foldr (fn (t, (abs, ran, n)) => + ((L'.EAbs ("arg" ^ Int.toString n, + t, + ran, + abs), loc), + (L'.TFun (t, ran), loc), + n - 1)) (app, result, length args - 1) args + in + abs + end + | _ => (L'.EFfi (m, x), loc) end | L.EApp (e1, e2) => (L'.EApp (corifyExp st e1, corifyExp st e2), loc) | L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, corifyCon st dom, corifyCon st ran, corifyExp st e1), loc) @@ -630,36 +649,48 @@ | L.SgiDatatype (x, n, xnts) => let val (st, n') = St.bindCon st x n - val (xnts, (st, cmap, conmap)) = + val (xnts, (ds', st, cmap, conmap)) = ListUtil.foldlMap - (fn ((x', n, to), (st, cmap, conmap)) => + (fn ((x', n, to), (ds', st, cmap, conmap)) => let - val st = St.bindConstructor st x' n - (L'.PConFfi {mod = m, - datatyp = x, - con = x'}) - val st = St.bindConstructorVal st x' n - val dt = (L'.CNamed n', loc) - val (to, cmap) = + val to = Option.map (corifyCon st) to + + val pc = L'.PConFfi {mod = m, + datatyp = x, + con = x', + arg = to} + + val (cmap, d) = case to of - NONE => (NONE, SM.insert (cmap, x', dt)) + NONE => (SM.insert (cmap, x', dt), + (L'.DVal (x', n, dt, + (L'.ECon (pc, NONE), loc), + ""), loc)) | SOME t => let - val t = corifyCon st t + val tf = (L'.TFun (t, dt), loc) + val d = (L'.DVal (x', n, tf, + (L'.EAbs ("x", t, tf, + (L'.ECon (pc, + SOME (L'.ERel 0, + loc)), + loc)), loc), ""), loc) in - (SOME t, SM.insert (cmap, x', - (L'.TFun (t, dt), loc))) + (SM.insert (cmap, x', tf), d) end - val conmap = SM.insert (conmap, x', x) + val st = St.bindConstructor st x' n pc + (*val st = St.bindConstructorVal st x' n*) + + val conmap = SM.insert (conmap, x', (x, to)) in ((x', n, to), - (st, cmap, conmap)) - end) (st, cmap, conmap) xnts + (d :: ds', st, cmap, conmap)) + end) ([], st, cmap, conmap) xnts in - ((L'.DDatatype (x, n', xnts), loc) :: ds, + (ds' @ (L'.DDatatype (x, n', xnts), loc) :: ds, cmap, conmap, st)
--- a/src/elab_env.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/elab_env.sml Sun Aug 03 18:53:20 2008 -0400 @@ -648,6 +648,7 @@ | DDatatype (x, n, xncs) => let val env = pushCNamedAs env x n (KType, loc) NONE + val env = pushDatatype env n xncs in foldl (fn ((x', n', NONE), env) => pushENamedAs env x' n' (CNamed n, loc) | ((x', n', SOME t), env) => pushENamedAs env x' n' (TFun (t, (CNamed n, loc)), loc)) @@ -657,6 +658,7 @@ let val t = (CModProj (m, ms, x'), loc) val env = pushCNamedAs env x n (KType, loc) (SOME t) + val env = pushDatatype env n xncs val t = (CNamed n, loc) in
--- a/src/mono.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/mono.sml Sun Aug 03 18:53:20 2008 -0400 @@ -39,7 +39,7 @@ datatype patCon = PConVar of int - | PConFfi of {mod : string, datatyp : string, con : string} + | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} datatype pat' = PWild
--- a/src/mono_print.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/mono_print.sml Sun Aug 03 18:53:20 2008 -0400 @@ -80,7 +80,7 @@ fun p_patCon env pc = case pc of PConVar n => p_con_named env n - | PConFfi {mod = m, con, ...} => box [string "FFI(", + | PConFfi {mod = m, con, ...} => box [string "FFIC(", string m, string ".", string con,
--- a/src/monoize.sml Sun Aug 03 17:57:47 2008 -0400 +++ b/src/monoize.sml Sun Aug 03 18:53:20 2008 -0400 @@ -286,17 +286,18 @@ end -fun monoPatCon pc = +fun monoPatCon env pc = case pc of L.PConVar n => L'.PConVar n - | L.PConFfi mx => L'.PConFfi mx + | L.PConFfi {mod = m, datatyp, con, arg} => L'.PConFfi {mod = m, datatyp = datatyp, con = con, + arg = Option.map (monoType env) arg} fun monoPat env (p, loc) = case p of L.PWild => (L'.PWild, loc) | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) | L.PPrim p => (L'.PPrim p, loc) - | L.PCon (pc, po) => (L'.PCon (monoPatCon pc, Option.map (monoPat env) po), loc) + | L.PCon (pc, po) => (L'.PCon (monoPatCon env pc, Option.map (monoPat env) po), loc) | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) fun monoExp (env, st, fm) (all as (e, loc)) = @@ -322,7 +323,7 @@ (SOME e, fm) end in - ((L'.ECon (monoPatCon pc, eo), loc), fm) + ((L'.ECon (monoPatCon env pc, eo), loc), fm) end | L.EFfi mx => ((L'.EFfi mx, loc), fm) | L.EFfiApp (m, x, es) =>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/bool.lac Sun Aug 03 18:53:20 2008 -0400 @@ -0,0 +1,8 @@ +val page = fn b => <html><body> + {cdata (case b of False => "No!" | True => "Yes!")} +</body></html> + +val main : unit -> page = fn () => <html><body> + <li><a link={page True}>True</a></li> + <li><a link={page False}>False</a></li> +</body></html>