Mercurial > urweb

comparison src/cjr_print.sml @ 144:f0d3402184d1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Simple forms work
author Adam Chlipala <adamc@hcoop.net>
date Tue, 22 Jul 2008 15:12:20 -0400
parents 4b9c2bd6157c
children e52dfb1e6b19
comparison
equal deleted inserted replaced
143:4b9c2bd6157c 144:f0d3402184d1
35 open Cjr 35 open Cjr
36 36
37 structure E = CjrEnv 37 structure E = CjrEnv
38 structure EM = ErrorMsg 38 structure EM = ErrorMsg
39 39
40 structure SK = struct
41 type ord_key = string
42 val compare = String.compare
43 end
44
45 structure SS = BinarySetFn(SK)
46 structure SM = BinaryMapFn(SK)
47 structure IS = IntBinarySet
48
49 structure CM = BinaryMapFn(struct
50 type ord_key = char
51 val compare = Char.compare
52 end)
53
40 val debug = ref false 54 val debug = ref false
41 55
42 val dummyTyp = (TNamed 0, ErrorMsg.dummySpan) 56 val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
43 57
44 fun p_typ' par env (t, loc) = 58 fun p_typ' par env (t, loc) =
206 newline, 220 newline,
207 p_list_sep newline (p_fun env) vis, 221 p_list_sep newline (p_fun env) vis,
208 newline] 222 newline]
209 end 223 end
210 224
211 fun unurlify env (t, loc) = 225 datatype 'a search =
212 case t of 226 Found of 'a
213 TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)" 227 | NotFound
214 | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)" 228 | Error
215 | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)" 229
216
217 | TRecord 0 => string "lw_unit_v"
218 | TRecord i =>
219 let
220 val xts = E.lookupStruct env i
221 in
222 box [string "({",
223 newline,
224 box (map (fn (x, t) =>
225 box [p_typ env t,
226 space,
227 string x,
228 space,
229 string "=",
230 space,
231 unurlify env t,
232 string ";",
233 newline]) xts),
234 string "struct",
235 space,
236 string "__lws_",
237 string (Int.toString i),
238 space,
239 string "__lw_tmp",
240 space,
241 string "=",
242 space,
243 string "{",
244 space,
245 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
246 space,
247 string "};",
248 newline,
249 string "__lw_tmp;",
250 newline,
251 string "})"]
252 end
253
254 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
255 space)
256
257 fun p_page env (s, n, ts) =
258 box [string "if (!strncmp(request, \"",
259 string (String.toString s),
260 string "\", ",
261 string (Int.toString (size s)),
262 string ")) {",
263 newline,
264 string "request += ",
265 string (Int.toString (size s)),
266 string ";",
267 newline,
268 string "if (*request == '/') ++request;",
269 newline,
270 box [string "{",
271 newline,
272 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
273 space,
274 string "arg",
275 string (Int.toString i),
276 space,
277 string "=",
278 space,
279 unurlify env t,
280 string ";",
281 newline]) ts),
282 p_enamed env n,
283 string "(",
284 p_list_sep (box [string ",", space])
285 (fn x => x)
286 (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
287 string ");",
288 newline,
289 string "return;",
290 newline,
291 string "}",
292 newline,
293 string "}"]
294 ]
295 230
296 fun p_file env (ds, ps) = 231 fun p_file env (ds, ps) =
297 let 232 let
298 val (pds, env) = ListUtil.foldlMap (fn (d, env) => 233 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
299 (p_decl env d, 234 (p_decl env d,
300 E.declBinds env d)) 235 E.declBinds env d))
301 env ds 236 env ds
302 val pds' = map (p_page env) ps 237
238 val fields = foldl (fn ((ek, _, _, ts), fields) =>
239 case ek of
240 Core.Link => fields
241 | Core.Action =>
242 case List.last ts of
243 (TRecord i, _) =>
244 let
245 val xts = E.lookupStruct env i
246 val xtsSet = SS.addList (SS.empty, map #1 xts)
247 in
248 foldl (fn ((x, _), fields) =>
249 let
250 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
251 in
252 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
253 xtsSet'))
254 end) fields xts
255 end
256 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
257 SM.empty ps
258
259 val fnums = SM.foldli (fn (x, xs, fnums) =>
260 let
261 val unusable = SS.foldl (fn (x', unusable) =>
262 case SM.find (fnums, x') of
263 NONE => unusable
264 | SOME n => IS.add (unusable, n))
265 IS.empty xs
266
267 fun findAvailable n =
268 if IS.member (unusable, n) then
269 findAvailable (n + 1)
270 else
271 n
272 in
273 SM.insert (fnums, x, findAvailable 0)
274 end)
275 SM.empty fields
276
277 fun makeSwitch (fnums, i) =
278 case SM.foldl (fn (n, NotFound) => Found n
279 | (n, Error) => Error
280 | (n, Found n') => if n = n' then
281 Found n'
282 else
283 Error) NotFound fnums of
284 NotFound => box [string "return",
285 space,
286 string "-1;"]
287 | Found n => box [string "return",
288 space,
289 string (Int.toString n),
290 string ";"]
291 | Error =>
292 let
293 val cmap = SM.foldli (fn (x, n, cmap) =>
294 let
295 val ch = if i < size x then
296 String.sub (x, i)
297 else
298 chr 0
299
300 val fnums = case CM.find (cmap, ch) of
301 NONE => SM.empty
302 | SOME fnums => fnums
303 val fnums = SM.insert (fnums, x, n)
304 in
305 CM.insert (cmap, ch, fnums)
306 end)
307 CM.empty fnums
308
309 val cmap = CM.listItemsi cmap
310 in
311 case cmap of
312 [(_, fnums)] =>
313 box [string "if",
314 space,
315 string "(name[",
316 string (Int.toString i),
317 string "]",
318 space,
319 string "==",
320 space,
321 string "0)",
322 space,
323 string "return",
324 space,
325 string "-1;",
326 newline,
327 makeSwitch (fnums, i+1)]
328 | _ =>
329 box [string "switch",
330 space,
331 string "(name[",
332 string (Int.toString i),
333 string "])",
334 space,
335 string "{",
336 newline,
337 box (map (fn (ch, fnums) =>
338 box [string "case",
339 space,
340 if ch = chr 0 then
341 string "0:"
342 else
343 box [string "'",
344 string (Char.toString ch),
345 string "':"],
346 newline,
347 makeSwitch (fnums, i+1),
348 newline]) cmap),
349 string "default:",
350 newline,
351 string "return",
352 space,
353 string "-1;",
354 newline,
355 string "}"]
356 end
357
358 fun unurlify (t, loc) =
359 case t of
360 TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
361 | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
362 | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
363
364 | TRecord 0 => string "lw_unit_v"
365 | TRecord i =>
366 let
367 val xts = E.lookupStruct env i
368 in
369 box [string "({",
370 newline,
371 box (map (fn (x, t) =>
372 box [p_typ env t,
373 space,
374 string x,
375 space,
376 string "=",
377 space,
378 unurlify t,
379 string ";",
380 newline]) xts),
381 string "struct",
382 space,
383 string "__lws_",
384 string (Int.toString i),
385 space,
386 string "__lw_tmp",
387 space,
388 string "=",
389 space,
390 string "{",
391 space,
392 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
393 space,
394 string "};",
395 newline,
396 string "__lw_tmp;",
397 newline,
398 string "})"]
399 end
400
401 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
402 space)
403
404
405 fun p_page (ek, s, n, ts) =
406 let
407 val (ts, defInputs, inputsVar) =
408 case ek of
409 Core.Link => (ts, string "", string "")
410 | Core.Action =>
411 case List.last ts of
412 (TRecord i, _) =>
413 let
414 val xts = E.lookupStruct env i
415 in
416 (List.drop (ts, 1),
417 box [box (map (fn (x, t) => box [p_typ env t,
418 space,
419 string "lw_input_",
420 string x,
421 string ";",
422 newline]) xts),
423 newline,
424 box (map (fn (x, t) =>
425 let
426 val n = case SM.find (fnums, x) of
427 NONE => raise Fail "CjrPrint: Can't find in fnums"
428 | SOME n => n
429 in
430 box [string "request = lw_get_input(ctx, ",
431 string (Int.toString n),
432 string ");",
433 newline,
434 string "if (request == NULL) {",
435 newline,
436 box [string "printf(\"Missing input ",
437 string x,
438 string "\\n\");",
439 newline,
440 string "exit(1);"],
441 newline,
442 string "}",
443 newline,
444 string "lw_input_",
445 string x,
446 space,
447 string "=",
448 space,
449 unurlify t,
450 string ";",
451 newline]
452 end) xts),
453 string "struct __lws_",
454 string (Int.toString i),
455 space,
456 string "lw_inputs",
457 space,
458 string "= {",
459 newline,
460 box (map (fn (x, _) => box [string "lw_input_",
461 string x,
462 string ",",
463 newline]) xts),
464 string "};",
465 newline],
466 box [string ",",
467 space,
468 string "lw_inputs"])
469 end
470
471 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
472 in
473 box [string "if (!strncmp(request, \"",
474 string (String.toString s),
475 string "\", ",
476 string (Int.toString (size s)),
477 string ")) {",
478 newline,
479 string "request += ",
480 string (Int.toString (size s)),
481 string ";",
482 newline,
483 string "if (*request == '/') ++request;",
484 newline,
485 box [string "{",
486 newline,
487 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
488 space,
489 string "arg",
490 string (Int.toString i),
491 space,
492 string "=",
493 space,
494 unurlify t,
495 string ";",
496 newline]) ts),
497 defInputs,
498 p_enamed env n,
499 string "(",
500 p_list_sep (box [string ",", space])
501 (fn x => x)
502 (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
503 inputsVar,
504 string ");",
505 newline,
506 string "return;",
507 newline,
508 string "}",
509 newline,
510 string "}"]
511 ]
512 end
513
514 val pds' = map p_page ps
303 in 515 in
304 box [string "#include \"lacweb.h\"", 516 box [string "#include <stdio.h>",
517 newline,
518 string "#include <stdlib.h>",
519 newline,
520 newline,
521 string "#include \"lacweb.h\"",
305 newline, 522 newline,
306 newline, 523 newline,
307 p_list_sep newline (fn x => x) pds, 524 p_list_sep newline (fn x => x) pds,
525 newline,
526 string "int lw_inputs_len = ",
527 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
528 string ";",
529 newline,
530 newline,
531 string "int lw_input_num(char *name) {",
532 newline,
533 string "if",
534 space,
535 string "(name[0]",
536 space,
537 string "==",
538 space,
539 string "0)",
540 space,
541 string "return",
542 space,
543 string "-1;",
544 newline,
545 makeSwitch (fnums, 0),
546 string "}",
547 newline,
308 newline, 548 newline,
309 string "void lw_handle(lw_context ctx, char *request) {", 549 string "void lw_handle(lw_context ctx, char *request) {",
310 newline, 550 newline,
311 p_list_sep newline (fn x => x) pds', 551 p_list_sep newline (fn x => x) pds',
312 newline, 552 newline,