Mercurial > urweb

comparison src/monoize.sml @ 143:4b9c2bd6157c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Almost ready to have a form work
author Adam Chlipala <adamc@hcoop.net>
date Sun, 20 Jul 2008 13:30:19 -0400
parents 63c699450281
children f0d3402184d1
comparison
equal deleted inserted replaced
142:6f9e224692ec 143:4b9c2bd6157c
59 | L.TCFun _ => poly () 59 | L.TCFun _ => poly ()
60 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) => 60 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
61 (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc) 61 (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc)
62 | L.TRecord _ => poly () 62 | L.TRecord _ => poly ()
63 63
64 | L.CApp ((L.CFfi ("Basis", "xml"), _), _) => (L'.TFfi ("Basis", "string"), loc) 64 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
65 (L'.TFfi ("Basis", "string"), loc)
65 66
66 | L.CRel _ => poly () 67 | L.CRel _ => poly ()
67 | L.CNamed n => (L'.TNamed n, loc) 68 | L.CNamed n => (L'.TNamed n, loc)
68 | L.CFfi mx => (L'.TFfi mx, loc) 69 | L.CFfi mx => (L'.TFfi mx, loc)
69 | L.CApp _ => poly () 70 | L.CApp _ => poly ()
122 end 123 end
123 124
124 val attrifyExp = fooifyExp "attr" 125 val attrifyExp = fooifyExp "attr"
125 val urlifyExp = fooifyExp "url" 126 val urlifyExp = fooifyExp "url"
126 127
128 datatype 'a failable_search =
129 Found of 'a
130 | NotFound
131 | Error
132
127 fun monoExp env (all as (e, loc)) = 133 fun monoExp env (all as (e, loc)) =
128 let 134 let
129 fun poly () = 135 fun poly () =
130 (E.errorAt loc "Unsupported expression"; 136 (E.errorAt loc "Unsupported expression";
131 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 137 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
174 tag), _), 180 tag), _),
175 xml) => 181 xml) =>
176 let 182 let
177 fun getTag' (e, _) = 183 fun getTag' (e, _) =
178 case e of 184 case e of
179 L.EFfi ("Basis", tag) => tag 185 L.EFfi ("Basis", tag) => (tag, [])
180 | L.ECApp (e, _) => getTag' e 186 | L.ECApp (e, t) => let
187 val (tag, ts) = getTag' e
188 in
189 (tag, ts @ [t])
190 end
181 | _ => (E.errorAt loc "Non-constant XML tag"; 191 | _ => (E.errorAt loc "Non-constant XML tag";
182 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; 192 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
183 "") 193 ("", []))
184 194
185 fun getTag (e, _) = 195 fun getTag (e, _) =
186 case e of 196 case e of
187 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => tag 197 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
188 | L.EApp (e, (L.ERecord [], _)) => getTag' e 198 | L.EApp (e, (L.ERecord [], _)) => getTag' e
189 | _ => (E.errorAt loc "Non-constant XML tag"; 199 | _ => (E.errorAt loc "Non-constant XML tag";
190 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; 200 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
191 "") 201 ("", []))
192 202
193 val tag = getTag tag 203 val (tag, targs) = getTag tag
194 204
195 val attrs = monoExp env attrs 205 val attrs = monoExp env attrs
196 206
197 val tagStart = 207 fun tagStart tag =
198 case #1 attrs of 208 case #1 attrs of
199 L'.ERecord xes => 209 L'.ERecord xes =>
200 let 210 let
201 fun lowercaseFirst "" = "" 211 fun lowercaseFirst "" = ""
202 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 212 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
213 ^ String.extract (s, 1, NONE)
203 214
204 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) 215 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
205 in 216 in
206 foldl (fn ((x, e, t), s) => 217 foldl (fn ((x, e, t), s) =>
207 let 218 let
208 val xp = " " ^ lowercaseFirst x ^ "=\"" 219 val xp = " " ^ lowercaseFirst x ^ "=\""
209 220
210 val fooify = 221 val fooify =
211 case x of 222 case x of
212 "Link" => urlifyExp 223 "Link" => urlifyExp
224 | "Action" => urlifyExp
213 | _ => attrifyExp 225 | _ => attrifyExp
214 in 226 in
215 (L'.EStrcat (s, 227 (L'.EStrcat (s,
216 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), 228 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
217 (L'.EStrcat (fooify env (e, t), 229 (L'.EStrcat (fooify env (e, t),
218 (L'.EPrim (Prim.String "\""), loc)), 230 (L'.EPrim (Prim.String "\""),
231 loc)),
219 loc)), 232 loc)),
220 loc)), loc) 233 loc)), loc)
221 end) 234 end)
222 s xes 235 s xes
223 end 236 end
224 | _ => raise Fail "Attributes!" 237 | _ => raise Fail "Non-record attributes!"
225 238
226 fun normal () = 239 fun input typ =
227 (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), 240 case targs of
228 (L'.EStrcat (monoExp env xml, 241 [(L.CName name, _)] =>
229 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), loc)), loc)), 242 (L'.EStrcat (tagStart "input",
230 loc) 243 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
231 244 loc)), loc)
232 245 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
246 raise Fail "No named passed to input tag")
233 in 247 in
234 case xml of 248 case tag of
235 (L.EApp ((L.ECApp ( 249 "submit" => (L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc)
236 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), 250
237 _), _), 251 | "textbox" =>
238 _), _), 252 (case targs of
239 (L.EPrim (Prim.String s), _)), _) => 253 [_, (L.CName name, _)] =>
240 if CharVector.all Char.isSpace s then 254 (L'.EStrcat (tagStart "input",
241 (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc) 255 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
242 else 256 loc)), loc)
243 normal () 257 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
244 | _ => normal () 258 raise Fail "No named passed to input tag"))
259
260 | _ =>
261 let
262 val tagStart = tagStart tag
263
264 fun normal () =
265 (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
266 (L'.EStrcat (monoExp env xml,
267 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
268 loc)), loc)),
269 loc)
270 in
271 case xml of
272 (L.EApp ((L.ECApp (
273 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
274 _), _),
275 _), _),
276 (L.EPrim (Prim.String s), _)), _) =>
277 if CharVector.all Char.isSpace s then
278 (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
279 else
280 normal ()
281 | _ => normal ()
282 end
245 end 283 end
246 284
247 | L.EApp ((L.ECApp ( 285 | L.EApp ((L.ECApp (
248 (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _), 286 (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
249 _), _), 287 _), _),
250 xml) => 288 xml) =>
251 (L'.EStrcat ((L'.EPrim (Prim.String "<form>"), loc), 289 let
252 (L'.EStrcat (monoExp env xml, 290 fun findSubmit (e, _) =
253 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc) 291 case e of
292 L.EApp (
293 (L.EApp (
294 (L.ECApp (
295 (L.ECApp (
296 (L.ECApp (
297 (L.ECApp (
298 (L.EFfi ("Basis", "join"),
299 _), _), _),
300 _), _),
301 _), _),
302 _), _),
303 xml1), _),
304 xml2) => (case findSubmit xml1 of
305 Error => Error
306 | NotFound => findSubmit xml2
307 | Found e =>
308 case findSubmit xml2 of
309 NotFound => Found e
310 | _ => Error)
311 | L.EApp (
312 (L.EApp (
313 (L.EApp (
314 (L.ECApp (
315 (L.ECApp (
316 (L.ECApp (
317 (L.ECApp (
318 (L.ECApp (
319 (L.ECApp (
320 (L.ECApp (
321 (L.ECApp (
322 (L.EFfi ("Basis", "tag"),
323 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
324 attrs), _),
325 _), _),
326 xml) =>
327 (case #1 attrs of
328 L.ERecord xes =>
329 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
330 | _ => NONE) xes of
331 NONE => findSubmit xml
332 | SOME et =>
333 case findSubmit xml of
334 NotFound => Found et
335 | _ => Error)
336 | _ => findSubmit xml)
337 | _ => NotFound
338
339 val (action, actionT) = case findSubmit xml of
340 NotFound => raise Fail "No submit found"
341 | Error => raise Fail "Not ready for multi-submit lforms yet"
342 | Found et => et
343
344 val actionT = monoType env actionT
345 val action = monoExp env action
346 in
347 (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
348 (L'.EStrcat (urlifyExp env (action, actionT),
349 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
350 (L'.EStrcat (monoExp env xml,
351 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
352 end
254 353
255 | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc) 354 | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
256 | L.EAbs (x, dom, ran, e) => 355 | L.EAbs (x, dom, ran, e) =>
257 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom) e), loc) 356 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom) e), loc)
258 | L.ECApp _ => poly () 357 | L.ECApp _ => poly ()