aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr_print.sml39
-rw-r--r--src/monoize.sml167
-rw-r--r--src/tag.sml95
3 files changed, 221 insertions, 80 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 4cf3300d..218fcdee 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -208,13 +208,48 @@ fun p_decl env (dAll as (d, _) : decl) =
newline]
end
-fun unurlify (t, loc) =
+fun unurlify env (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)"
| TRecord 0 => string "lw_unit_v"
+ | TRecord i =>
+ let
+ val xts = E.lookupStruct env i
+ in
+ box [string "({",
+ newline,
+ box (map (fn (x, t) =>
+ box [p_typ env t,
+ space,
+ string x,
+ space,
+ string "=",
+ space,
+ unurlify env t,
+ string ";",
+ newline]) xts),
+ string "struct",
+ space,
+ string "__lws_",
+ string (Int.toString i),
+ space,
+ string "__lw_tmp",
+ space,
+ string "=",
+ space,
+ string "{",
+ space,
+ p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
+ space,
+ string "};",
+ newline,
+ string "__lw_tmp;",
+ newline,
+ string "})"]
+ end
| _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
space)
@@ -241,7 +276,7 @@ fun p_page env (s, n, ts) =
space,
string "=",
space,
- unurlify t,
+ unurlify env t,
string ";",
newline]) ts),
p_enamed env n,
diff --git a/src/monoize.sml b/src/monoize.sml
index ad177a64..dbe69c6a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -61,7 +61,8 @@ fun monoType env (all as (c, loc)) =
(L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc)
| L.TRecord _ => poly ()
- | L.CApp ((L.CFfi ("Basis", "xml"), _), _) => (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
| L.CRel _ => poly ()
| L.CNamed n => (L'.TNamed n, loc)
@@ -124,6 +125,11 @@ fun fooifyExp name env =
val attrifyExp = fooifyExp "attr"
val urlifyExp = fooifyExp "url"
+datatype 'a failable_search =
+ Found of 'a
+ | NotFound
+ | Error
+
fun monoExp env (all as (e, loc)) =
let
fun poly () =
@@ -176,30 +182,35 @@ fun monoExp env (all as (e, loc)) =
let
fun getTag' (e, _) =
case e of
- L.EFfi ("Basis", tag) => tag
- | L.ECApp (e, _) => getTag' e
+ L.EFfi ("Basis", tag) => (tag, [])
+ | L.ECApp (e, t) => let
+ val (tag, ts) = getTag' e
+ in
+ (tag, ts @ [t])
+ end
| _ => (E.errorAt loc "Non-constant XML tag";
Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
- "")
+ ("", []))
fun getTag (e, _) =
case e of
- L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => tag
+ L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
| L.EApp (e, (L.ERecord [], _)) => getTag' e
| _ => (E.errorAt loc "Non-constant XML tag";
Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
- "")
+ ("", []))
- val tag = getTag tag
+ val (tag, targs) = getTag tag
val attrs = monoExp env attrs
- val tagStart =
+ fun tagStart tag =
case #1 attrs of
L'.ERecord xes =>
let
fun lowercaseFirst "" = ""
- | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+ | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
+ ^ String.extract (s, 1, NONE)
val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
in
@@ -210,47 +221,135 @@ fun monoExp env (all as (e, loc)) =
val fooify =
case x of
"Link" => urlifyExp
+ | "Action" => urlifyExp
| _ => attrifyExp
in
(L'.EStrcat (s,
(L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
(L'.EStrcat (fooify env (e, t),
- (L'.EPrim (Prim.String "\""), loc)),
+ (L'.EPrim (Prim.String "\""),
+ loc)),
loc)),
loc)), loc)
end)
- s xes
+ s xes
end
- | _ => raise Fail "Attributes!"
-
- fun normal () =
- (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
- (L'.EStrcat (monoExp env xml,
- (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), loc)), loc)),
- loc)
-
-
+ | _ => raise Fail "Non-record attributes!"
+
+ fun input typ =
+ case targs of
+ [(L.CName name, _)] =>
+ (L'.EStrcat (tagStart "input",
+ (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
+ loc)), loc)
+ | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
+ raise Fail "No named passed to input tag")
in
- case xml of
- (L.EApp ((L.ECApp (
- (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
- _), _),
- _), _),
- (L.EPrim (Prim.String s), _)), _) =>
- if CharVector.all Char.isSpace s then
- (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
- else
- normal ()
- | _ => normal ()
+ case tag of
+ "submit" => (L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc)
+
+ | "textbox" =>
+ (case targs of
+ [_, (L.CName name, _)] =>
+ (L'.EStrcat (tagStart "input",
+ (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
+ loc)), loc)
+ | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
+ raise Fail "No named passed to input tag"))
+
+ | _ =>
+ let
+ val tagStart = tagStart tag
+
+ fun normal () =
+ (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
+ (L'.EStrcat (monoExp env xml,
+ (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
+ loc)), loc)),
+ loc)
+ in
+ case xml of
+ (L.EApp ((L.ECApp (
+ (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
+ _), _),
+ _), _),
+ (L.EPrim (Prim.String s), _)), _) =>
+ if CharVector.all Char.isSpace s then
+ (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
+ else
+ normal ()
+ | _ => normal ()
+ end
end
| L.EApp ((L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
_), _),
xml) =>
- (L'.EStrcat ((L'.EPrim (Prim.String "<form>"), loc),
- (L'.EStrcat (monoExp env xml,
- (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
+ let
+ fun findSubmit (e, _) =
+ case e of
+ L.EApp (
+ (L.EApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "join"),
+ _), _), _),
+ _), _),
+ _), _),
+ _), _),
+ xml1), _),
+ xml2) => (case findSubmit xml1 of
+ Error => Error
+ | NotFound => findSubmit xml2
+ | Found e =>
+ case findSubmit xml2 of
+ NotFound => Found e
+ | _ => Error)
+ | L.EApp (
+ (L.EApp (
+ (L.EApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "tag"),
+ _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+ attrs), _),
+ _), _),
+ xml) =>
+ (case #1 attrs of
+ L.ERecord xes =>
+ (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
+ | _ => NONE) xes of
+ NONE => findSubmit xml
+ | SOME et =>
+ case findSubmit xml of
+ NotFound => Found et
+ | _ => Error)
+ | _ => findSubmit xml)
+ | _ => NotFound
+
+ val (action, actionT) = case findSubmit xml of
+ NotFound => raise Fail "No submit found"
+ | Error => raise Fail "Not ready for multi-submit lforms yet"
+ | Found et => et
+
+ val actionT = monoType env actionT
+ val action = monoExp env action
+ in
+ (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
+ (L'.EStrcat (urlifyExp env (action, actionT),
+ (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
+ (L'.EStrcat (monoExp env xml,
+ (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
+ end
| L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
| L.EAbs (x, dom, ran, e) =>
diff --git a/src/tag.sml b/src/tag.sml
index 53966bf9..3bd9f3f1 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -65,50 +65,57 @@ fun exp env (e, s) =
let
val (xets, s) =
ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
- case x of
- (CName "Link", _) =>
- let
- fun unravel (e, _) =
- case e of
- ENamed n => (n, [])
- | EApp (e1, e2) =>
- let
- val (n, es) = unravel e1
- in
- (n, es @ [e2])
- end
- | _ => (ErrorMsg.errorAt loc "Invalid link expression";
- (0, []))
-
- val (f, args) = unravel e
-
- val (cn, count, tags, newTags) =
- case IM.find (tags, f) of
- NONE =>
- (count, count + 1, IM.insert (tags, f, count),
- (f, count) :: newTags)
- | SOME cn => (cn, count, tags, newTags)
-
- val (_, _, _, s) = E.lookupENamed env f
-
- val byTag = case SM.find (byTag, s) of
- NONE => SM.insert (byTag, s, f)
- | SOME f' =>
- (if f = f' then
- ()
- else
- ErrorMsg.errorAt loc
- ("Duplicate HTTP tag "
- ^ s);
- byTag)
-
- val e = (EClosure (cn, args), loc)
- val t = (CFfi ("Basis", "string"), loc)
- in
- (((CName "href", loc), e, t),
- (count, tags, byTag, newTags))
- end
- | _ => ((x, e, t), (count, tags, byTag, newTags)))
+ let
+ fun tagIt newAttr =
+ let
+ fun unravel (e, _) =
+ case e of
+ ENamed n => (n, [])
+ | EApp (e1, e2) =>
+ let
+ val (n, es) = unravel e1
+ in
+ (n, es @ [e2])
+ end
+ | _ => (ErrorMsg.errorAt loc "Invalid link expression";
+ (0, []))
+
+
+
+ val (f, args) = unravel e
+
+ val (cn, count, tags, newTags) =
+ case IM.find (tags, f) of
+ NONE =>
+ (count, count + 1, IM.insert (tags, f, count),
+ (f, count) :: newTags)
+ | SOME cn => (cn, count, tags, newTags)
+
+ val (_, _, _, s) = E.lookupENamed env f
+
+ val byTag = case SM.find (byTag, s) of
+ NONE => SM.insert (byTag, s, f)
+ | SOME f' =>
+ (if f = f' then
+ ()
+ else
+ ErrorMsg.errorAt loc
+ ("Duplicate HTTP tag "
+ ^ s);
+ byTag)
+
+ val e = (EClosure (cn, args), loc)
+ val t = (CFfi ("Basis", "string"), loc)
+ in
+ (((CName newAttr, loc), e, t),
+ (count, tags, byTag, newTags))
+ end
+ in
+ case x of
+ (CName "Link", _) => tagIt "Href"
+ | (CName "Action", _) => tagIt "Action"
+ | _ => ((x, e, t), (count, tags, byTag, newTags))
+ end)
s xets
in
(EApp (
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 04:21:12 +0000