Ur/Web: src/cjr_print.sml annotate

annotate src/cjr_print.sml @ 1609:c6cc104a47ac

Client-side timef

author	Adam Chlipala <adam@chlipala.net>
date	Thu, 24 Nov 2011 11:27:51 -0500
parents	02a50a9d50ea
children	4973d31b5fff

rev	line source
adam@1391	1 (* Copyright (c) 2008-2011, Adam Chlipala
adamc@29	2 * All rights reserved.
adamc@29	3 *
adamc@29	4 * Redistribution and use in source and binary forms, with or without
adamc@29	5 * modification, are permitted provided that the following conditions are met:
adamc@29	6 *
adamc@29	7 * - Redistributions of source code must retain the above copyright notice,
adamc@29	8 * this list of conditions and the following disclaimer.
adamc@29	9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@29	10 * this list of conditions and the following disclaimer in the documentation
adamc@29	11 * and/or other materials provided with the distribution.
adamc@29	12 * - The names of contributors may not be used to endorse or promote products
adamc@29	13 * derived from this software without specific prior written permission.
adamc@29	14 *
adamc@29	15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@29	16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@29	17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@29	18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@29	19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@29	20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@29	21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@29	22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@29	23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@29	24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@29	25 * POSSIBILITY OF SUCH DAMAGE.
adamc@29	26 *)
adamc@29	27
adamc@29	28 (* Pretty-printing C jr. *)
adamc@29	29
adamc@29	30 structure CjrPrint :> CJR_PRINT = struct
adamc@29	31
adamc@29	32 open Print.PD
adamc@29	33 open Print
adamc@29	34
adamc@29	35 open Cjr
adamc@29	36
adamc@269	37 val dummyt = (TRecord 0, ErrorMsg.dummySpan)
adamc@269	38
adamc@29	39 structure E = CjrEnv
adamc@29	40 structure EM = ErrorMsg
adamc@29	41
adamc@144	42 structure SK = struct
adamc@144	43 type ord_key = string
adamc@144	44 val compare = String.compare
adamc@144	45 end
adamc@144	46
adamc@144	47 structure SS = BinarySetFn(SK)
adamc@144	48 structure SM = BinaryMapFn(SK)
adamc@144	49 structure IS = IntBinarySet
adamc@144	50
adamc@144	51 structure CM = BinaryMapFn(struct
adamc@144	52 type ord_key = char
adamc@144	53 val compare = Char.compare
adamc@144	54 end)
adamc@144	55
adamc@29	56 val debug = ref false
adamc@29	57
adamc@196	58 val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan)
adamc@29	59
adamc@316	60 val ident = String.translate (fn #"'" => "PRIME"
adamc@316	61 \| ch => str ch)
adamc@316	62
adamc@316	63 val p_ident = string o ident
adamc@316	64
adamc@463	65 fun isUnboxable (t : typ) =
adamc@463	66 case #1 t of
adamc@463	67 TDatatype (Default, _, _) => true
adamc@463	68 \| TFfi ("Basis", "string") => true
adam@1370	69 \| TFfi ("Basis", "queryString") => true
adamc@463	70 \| _ => false
adamc@463	71
adamc@29	72 fun p_typ' par env (t, loc) =
adamc@29	73 case t of
adamc@476	74 TFun (t1, t2) => (EM.errorAt loc "Function type remains";
adamc@476	75 string "<FUNCTION>")
adam@1431	76 \| TRecord 0 => string "uw_unit"
adamc@29	77 \| TRecord i => box [string "struct",
adamc@29	78 space,
adamc@311	79 string "__uws_",
adamc@29	80 string (Int.toString i)]
adamc@188	81 \| TDatatype (Enum, n, _) =>
adamc@188	82 (box [string "enum",
adamc@188	83 space,
adamc@1257	84 string ("__uwe_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n)]
adamc@311	85 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
adamc@198	86 \| TDatatype (Option, n, xncs) =>
adamc@198	87 (case ListUtil.search #3 (!xncs) of
adamc@198	88 NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
adamc@198	89 \| SOME t =>
adamc@897	90 if isUnboxable t then
adamc@897	91 p_typ' par env t
adamc@897	92 else
adamc@897	93 box [p_typ' par env t,
adamc@897	94 string "*"])
adamc@188	95 \| TDatatype (Default, n, _) =>
adamc@165	96 (box [string "struct",
adamc@165	97 space,
adamc@1257	98 string ("__uwd_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n ^ "*")]
adamc@311	99 handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
adamc@316	100 \| TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
adamc@288	101 \| TOption t =>
adamc@463	102 if isUnboxable t then
adamc@463	103 p_typ' par env t
adamc@463	104 else
adamc@463	105 box [p_typ' par env t,
adamc@463	106 string "*"]
adamc@757	107 \| TList (_, i) => box [string "struct",
adamc@757	108 space,
adamc@757	109 string "__uws_",
adamc@757	110 string (Int.toString i),
adamc@757	111 string "*"]
adamc@29	112
adamc@29	113 and p_typ env = p_typ' false env
adamc@29	114
adamc@316	115 fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@311	116 handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29	117
adam@1294	118 fun p_enamed' env n =
adam@1294	119 "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n
adam@1294	120 handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n
adam@1294	121
adam@1294	122 fun p_enamed env n = string (p_enamed' env n)
adamc@109	123
adamc@182	124 fun p_con_named env n =
adamc@316	125 string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n)
adamc@311	126 handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n)
adamc@182	127
adamc@182	128 fun p_pat_preamble env (p, _) =
adamc@182	129 case p of
adamc@182	130 PWild => (box [],
adamc@182	131 env)
adamc@182	132 \| PVar (x, t) => (box [p_typ env t,
adamc@182	133 space,
adamc@311	134 string "__uwr_",
adamc@316	135 p_ident x,
adamc@182	136 string "_",
adamc@182	137 string (Int.toString (E.countERels env)),
adamc@182	138 string ";",
adamc@182	139 newline],
adamc@196	140 E.pushERel env x t)
adamc@182	141 \| PPrim _ => (box [], env)
adamc@188	142 \| PCon (_, _, NONE) => (box [], env)
adamc@188	143 \| PCon (_, _, SOME p) => p_pat_preamble env p
adamc@182	144 \| PRecord xps =>
adamc@182	145 foldl (fn ((_, p, _), (pp, env)) =>
adamc@182	146 let
adamc@182	147 val (pp', env) = p_pat_preamble env p
adamc@182	148 in
adamc@182	149 (box [pp', pp], env)
adamc@182	150 end) (box [], env) xps
adamc@288	151 \| PNone _ => (box [], env)
adamc@288	152 \| PSome (_, p) => p_pat_preamble env p
adamc@182	153
adamc@182	154 fun p_patCon env pc =
adamc@182	155 case pc of
adamc@182	156 PConVar n => p_con_named env n
adamc@316	157 \| PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con)
adamc@182	158
adam@1431	159 fun p_patMatch (env, disc) (p, loc) =
adamc@182	160 case p of
adam@1431	161 PWild => string "1"
adam@1431	162 \| PVar _ => string "1"
adam@1431	163 \| PPrim (Prim.Int n) => box [string ("(" ^ disc),
adam@1431	164 space,
adam@1431	165 string "==",
adam@1431	166 space,
adam@1431	167 Prim.p_t_GCC (Prim.Int n),
adam@1431	168 string ")"]
adam@1431	169 \| PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc),
adam@1431	170 string ",",
adam@1431	171 space,
adam@1431	172 Prim.p_t_GCC (Prim.String s),
adam@1431	173 string ")"]
adam@1431	174 \| PPrim (Prim.Char ch) => box [string ("(" ^ disc),
adam@1431	175 space,
adam@1431	176 string "==",
adam@1431	177 space,
adam@1431	178 Prim.p_t_GCC (Prim.Char ch),
adam@1431	179 string ")"]
adamc@182	180 \| PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
adamc@182	181
adamc@188	182 \| PCon (dk, pc, po) =>
adamc@182	183 let
adam@1431	184 val p =
adamc@182	185 case po of
adam@1431	186 NONE => box []
adamc@182	187 \| SOME p =>
adamc@182	188 let
adamc@182	189 val (x, to) = case pc of
adamc@182	190 PConVar n =>
adamc@182	191 let
adamc@182	192 val (x, to, _) = E.lookupConstructor env n
adamc@182	193 in
adamc@316	194 ("uw_" ^ ident x, to)
adamc@182	195 end
adamc@188	196 \| PConFfi {mod = m, con, arg, ...} =>
adamc@316	197 ("uw_" ^ ident m ^ "_" ^ ident con, arg)
adamc@182	198
adamc@182	199 val t = case to of
adamc@182	200 NONE => raise Fail "CjrPrint: Constructor mismatch"
adamc@182	201 \| SOME t => t
adam@1431	202
adam@1431	203 val x = case pc of
adam@1431	204 PConVar n =>
adam@1431	205 let
adam@1431	206 val (x, _, _) = E.lookupConstructor env n
adam@1431	207 in
adam@1431	208 "uw_" ^ ident x
adam@1431	209 end
adam@1431	210 \| PConFfi {mod = m, con, ...} =>
adam@1431	211 "uw_" ^ ident m ^ "_" ^ ident con
adam@1431	212
adam@1431	213 val disc' = case dk of
adam@1431	214 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
adam@1431	215 \| Default => disc ^ "->data." ^ x
adam@1431	216 \| Option =>
adam@1431	217 if isUnboxable t then
adam@1431	218 disc
adam@1431	219 else
adam@1431	220 "(*" ^ disc ^ ")"
adam@1431	221
adam@1431	222 val p = p_patMatch (env, disc') p
adamc@182	223 in
adam@1431	224 box [space,
adam@1431	225 string "&&",
adam@1431	226 space,
adam@1431	227 p]
adamc@182	228 end
adamc@182	229 in
adam@1431	230 box [string disc,
adam@1431	231 case (dk, po) of
adam@1431	232 (Enum, _) => box [space,
adam@1431	233 string "==",
adam@1431	234 space,
adam@1431	235 p_patCon env pc]
adam@1431	236 \| (Default, _) => box [string "->tag",
adam@1431	237 space,
adam@1431	238 string "==",
adam@1431	239 space,
adam@1431	240 p_patCon env pc]
adam@1431	241 \| (Option, NONE) => box [space,
adam@1431	242 string "==",
adam@1431	243 space,
adam@1431	244 string "NULL"]
adam@1431	245 \| (Option, SOME _) => box [space,
adam@1431	246 string "!=",
adam@1431	247 space,
adam@1431	248 string "NULL"],
adam@1431	249 p]
adam@1431	250 end
adam@1431	251
adam@1440	252 \| PRecord [] => string "1"
adam@1431	253 \| PRecord xps =>
adam@1431	254 p_list_sep (box [space, string "&&", space]) (fn (x, p, _) => p_patMatch (env, disc ^ ".__uwf_" ^ ident x) p) xps
adam@1431	255
adam@1431	256 \| PNone _ =>
adam@1431	257 box [string disc,
adam@1431	258 space,
adam@1431	259 string "==",
adam@1431	260 space,
adam@1431	261 string "NULL"]
adam@1431	262
adam@1431	263 \| PSome (t, p) =>
adam@1431	264 let
adam@1431	265 val disc' = if isUnboxable t then
adam@1431	266 disc
adam@1431	267 else
adam@1431	268 "(*" ^ disc ^ ")"
adam@1431	269
adam@1431	270 val p = p_patMatch (env, disc') p
adam@1431	271 in
adam@1431	272 box [string disc,
adam@1431	273 space,
adam@1431	274 string "!=",
adam@1431	275 space,
adam@1431	276 string "NULL",
adam@1431	277 space,
adam@1431	278 string "&&",
adam@1431	279 space,
adam@1431	280 p]
adam@1431	281 end
adam@1431	282
adam@1431	283 fun p_patBind (env, disc) (p, loc) =
adam@1431	284 case p of
adam@1431	285 PWild =>
adam@1431	286 (box [], env)
adam@1431	287 \| PVar (x, t) =>
adam@1431	288 (box [p_typ env t,
adam@1431	289 space,
adam@1431	290 string "__uwr_",
adam@1431	291 p_ident x,
adam@1431	292 string "_",
adam@1431	293 string (Int.toString (E.countERels env)),
adam@1431	294 space,
adam@1431	295 string "=",
adam@1431	296 space,
adam@1431	297 string disc,
adam@1431	298 string ";",
adam@1431	299 newline],
adam@1431	300 E.pushERel env x t)
adam@1431	301 \| PPrim _ => (box [], env)
adam@1431	302
adam@1431	303 \| PCon (_, _, NONE) => (box [], env)
adam@1431	304
adam@1431	305 \| PCon (dk, pc, SOME p) =>
adam@1431	306 let
adam@1431	307 val (x, to) = case pc of
adam@1431	308 PConVar n =>
adam@1431	309 let
adam@1431	310 val (x, to, _) = E.lookupConstructor env n
adam@1431	311 in
adam@1431	312 ("uw_" ^ ident x, to)
adam@1431	313 end
adam@1431	314 \| PConFfi {mod = m, con, arg, ...} =>
adam@1431	315 ("uw_" ^ ident m ^ "_" ^ ident con, arg)
adam@1431	316
adam@1431	317 val t = case to of
adam@1431	318 NONE => raise Fail "CjrPrint: Constructor mismatch"
adam@1431	319 \| SOME t => t
adam@1431	320
adam@1431	321 val disc' = case dk of
adam@1431	322 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
adam@1431	323 \| Default => disc ^ "->data." ^ x
adam@1431	324 \| Option =>
adam@1431	325 if isUnboxable t then
adam@1431	326 disc
adam@1431	327 else
adam@1431	328 "(*" ^ disc ^ ")"
adam@1431	329 in
adam@1431	330 p_patBind (env, disc') p
adamc@182	331 end
adamc@182	332
adamc@182	333 \| PRecord xps =>
adamc@182	334 let
adamc@182	335 val (xps, env) =
adam@1431	336 ListUtil.foldlMap (fn ((x, p, t), env) => p_patBind (env, disc ^ ".__uwf_" ^ ident x) p)
adam@1431	337 env xps
adamc@182	338 in
adam@1431	339 (p_list_sep (box []) (fn x => x) xps,
adamc@182	340 env)
adamc@182	341 end
adamc@182	342
adam@1431	343 \| PNone _ => (box [], env)
adamc@288	344
adamc@288	345 \| PSome (t, p) =>
adamc@288	346 let
adam@1431	347 val disc' = if isUnboxable t then
adam@1431	348 disc
adam@1431	349 else
adam@1431	350 "(*" ^ disc ^ ")"
adamc@288	351 in
adam@1431	352 p_patBind (env, disc') p
adamc@288	353 end
adamc@288	354
adamc@185	355 fun patConInfo env pc =
adamc@185	356 case pc of
adamc@185	357 PConVar n =>
adamc@185	358 let
adamc@185	359 val (x, _, dn) = E.lookupConstructor env n
adamc@185	360 val (dx, _) = E.lookupDatatype env dn
adamc@185	361 in
adamc@316	362 ("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn,
adamc@316	363 "__uwc_" ^ ident x ^ "_" ^ Int.toString n,
adamc@316	364 "uw_" ^ ident x)
adamc@185	365 end
adamc@186	366 \| PConFfi {mod = m, datatyp, con, ...} =>
adamc@316	367 ("uw_" ^ ident m ^ "_" ^ ident datatyp,
adamc@316	368 "uw_" ^ ident m ^ "_" ^ ident con,
adamc@316	369 "uw_" ^ ident con)
adamc@185	370
adamc@743	371 fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen =
adamc@278	372 case t of
adamc@311	373 TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
adamc@311	374 \| TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
adamc@324	375 \| TFfi ("Basis", "string") =>
adamc@324	376 if wontLeakStrings then
adamc@324	377 e
adamc@324	378 else
adamc@737	379 box [string "uw_strdup(ctx, ", e, string ")"]
adamc@311	380 \| TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
adamc@438	381 \| TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
adamc@743	382 \| TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, ",
adamc@743	383 e,
adamc@743	384 string ", ",
adamc@743	385 eLen,
adamc@743	386 string ")"]
adamc@678	387 \| TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
adamc@682	388 \| TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
adamc@467	389
adamc@278	390 \| _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
adamc@278	391 Print.eprefaces' [("Type", p_typ env tAll)];
adamc@278	392 string "ERROR")
adamc@278	393
adamc@467	394 fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
adamc@467	395 case t of
adamc@467	396 TOption t =>
adamc@747	397 box [string "(PQgetisnull(res, i, ",
adamc@467	398 string (Int.toString i),
adamc@467	399 string ") ? NULL : ",
adamc@467	400 case t of
adamc@467	401 (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i
adamc@467	402 \| _ => box [string "({",
adamc@467	403 newline,
adamc@467	404 p_typ env t,
adamc@467	405 space,
adamc@467	406 string "*tmp = uw_malloc(ctx, sizeof(",
adamc@467	407 p_typ env t,
adamc@467	408 string "));",
adamc@467	409 newline,
adamc@467	410 string "*tmp = ",
adamc@467	411 p_getcol wontLeakStrings env t i,
adamc@467	412 string ";",
adamc@467	413 newline,
adamc@467	414 string "tmp;",
adamc@467	415 newline,
adamc@467	416 string "})"],
adamc@467	417 string ")"]
adamc@467	418 \| _ =>
adamc@747	419 box [string "(PQgetisnull(res, i, ",
adamc@747	420 string (Int.toString i),
adamc@747	421 string ") ? ",
adamc@747	422 box [string "({",
adamc@747	423 p_typ env tAll,
adamc@747	424 space,
adamc@747	425 string "tmp;",
adamc@747	426 newline,
adamc@747	427 string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
adamc@747	428 string (Int.toString i),
adamc@747	429 string "\");",
adamc@747	430 newline,
adamc@747	431 string "tmp;",
adamc@747	432 newline,
adamc@747	433 string "})"],
adamc@747	434 string " : ",
adamc@747	435 p_unsql wontLeakStrings env tAll
adamc@747	436 (box [string "PQgetvalue(res, i, ",
adamc@747	437 string (Int.toString i),
adamc@747	438 string ")"])
adamc@747	439 (box [string "PQgetlength(res, i, ",
adamc@747	440 string (Int.toString i),
adamc@747	441 string ")"]),
adamc@747	442 string ")"]
adamc@467	443
adamc@867	444 datatype sql_type = datatype Settings.sql_type
adamc@867	445 val isBlob = Settings.isBlob
adamc@737	446
adamc@739	447 fun isFile (t : typ) =
adamc@737	448 case #1 t of
adamc@739	449 TFfi ("Basis", "file") => true
adamc@737	450 \| _ => false
adamc@737	451
adamc@1011	452 fun p_sql_type t = string (Settings.p_sql_ctype t)
adamc@282	453
adamc@282	454 fun getPargs (e, _) =
adamc@282	455 case e of
adamc@282	456 EPrim (Prim.String _) => []
adamc@282	457 \| EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
adamc@282	458
adamc@282	459 \| EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
adamc@282	460 \| EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
adamc@282	461 \| EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
adamc@282	462 \| EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
adamc@439	463 \| EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)]
adamc@737	464 \| EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)]
adamc@678	465 \| EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)]
adamc@682	466 \| EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)]
adamc@468	467
adamc@678	468 \| ECase (e,
adamc@678	469 [((PNone _, _),
adamc@678	470 (EPrim (Prim.String "NULL"), _)),
adamc@678	471 ((PSome (_, (PVar _, _)), _),
adamc@678	472 (EFfiApp (m, x, [(ERel 0, _)]), _))],
adamc@678	473 _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e))
adamc@468	474
adamc@491	475 \| ECase (e,
adamc@491	476 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
adamc@491	477 (EPrim (Prim.String "TRUE"), _)),
adamc@491	478 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
adamc@491	479 (EPrim (Prim.String "FALSE"), _))],
adamc@491	480 _) => [(e, Bool)]
adamc@282	481
adamc@282	482 \| _ => raise Fail "CjrPrint: getPargs"
adamc@282	483
adamc@1324	484 val notLeakies = SS.fromList ["int", "float", "char", "time", "bool", "unit", "client", "channel",
adamc@1324	485 "xhtml", "page", "xbody", "css_class"]
adamc@1324	486 val notLeakies' = SS.fromList ["blob"]
adamc@1324	487
adamc@324	488 fun notLeaky env allowHeapAllocated =
adamc@324	489 let
adamc@638	490 fun nl ok (t, _) =
adamc@324	491 case t of
adamc@324	492 TFun _ => false
adamc@324	493 \| TRecord n =>
adamc@324	494 let
adamc@324	495 val xts = E.lookupStruct env n
adamc@324	496 in
adamc@638	497 List.all (fn (_, t) => nl ok t) xts
adamc@324	498 end
adamc@638	499 \| TDatatype (dk, n, ref cons) =>
adamc@638	500 IS.member (ok, n)
adamc@638	501 orelse
adamc@638	502 ((allowHeapAllocated orelse dk = Enum)
adamc@638	503 andalso
adamc@638	504 let
adamc@638	505 val ok' = IS.add (ok, n)
adamc@638	506 in
adamc@638	507 List.all (fn (_, _, to) => case to of
adamc@638	508 NONE => true
adamc@638	509 \| SOME t => nl ok' t) cons
adamc@638	510 end)
adamc@1324	511 \| TFfi ("Basis", t) => SS.member (notLeakies, t)
adamc@1324	512 orelse (allowHeapAllocated andalso SS.member (notLeakies', t))
adamc@1324	513 \| TFfi _ => false
adamc@638	514 \| TOption t => allowHeapAllocated andalso nl ok t
adamc@757	515 \| TList (t, _) => allowHeapAllocated andalso nl ok t
adamc@324	516 in
adamc@638	517 nl IS.empty
adamc@324	518 end
adamc@324	519
adamc@463	520 fun capitalize s =
adamc@463	521 if s = "" then
adamc@463	522 ""
adamc@463	523 else
adamc@463	524 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@463	525
adam@1516	526 local
adam@1546	527 val urlHandlers = ref ([] : (pp_desc * pp_desc) list)
adam@1516	528 in
adam@1516	529
adam@1516	530 fun addUrlHandler v = urlHandlers := v :: !urlHandlers
adam@1516	531
adam@1516	532 fun latestUrlHandlers () =
adam@1516	533 !urlHandlers
adam@1516	534 before urlHandlers := []
adam@1516	535
adam@1516	536 fun clearUrlHandlers () = urlHandlers := []
adam@1516	537
adam@1516	538 end
adam@1516	539
adam@1516	540 val unurlifies = ref IS.empty
adam@1516	541
adamc@1023	542 fun unurlify fromClient env (t, loc) =
adamc@463	543 let
adam@1545	544 fun deStar request =
adam@1545	545 case request of
adam@1545	546 "(*request)" => "request"
adam@1545	547 \| _ => "&" ^ request
adam@1545	548
adam@1516	549 fun unurlify' request t =
adamc@463	550 case t of
adam@1545	551 TFfi ("Basis", "unit") => string ("uw_Basis_unurlifyUnit(ctx, " ^ deStar request ^ ")")
adamc@1023	552 \| TFfi ("Basis", "string") => string (if fromClient then
adam@1545	553 "uw_Basis_unurlifyString_fromClient(ctx, " ^ deStar request ^ ")"
adamc@1023	554 else
adam@1545	555 "uw_Basis_unurlifyString(ctx, " ^ deStar request ^ ")")
adam@1545	556 \| TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, " ^ deStar request ^ ")")
adamc@463	557
adam@1545	558 \| TRecord 0 => string ("uw_Basis_unurlifyUnit(ctx, " ^ deStar request ^ ")")
adamc@463	559 \| TRecord i =>
adamc@463	560 let
adamc@463	561 val xts = E.lookupStruct env i
adamc@463	562 in
adamc@463	563 box [string "({",
adamc@463	564 newline,
adamc@463	565 box (map (fn (x, t) =>
adamc@463	566 box [p_typ env t,
adamc@463	567 space,
adamc@463	568 string "uwr_",
adamc@463	569 string x,
adamc@463	570 space,
adamc@463	571 string "=",
adamc@463	572 space,
adam@1516	573 unurlify' request (#1 t),
adamc@463	574 string ";",
adamc@463	575 newline]) xts),
adamc@463	576 string "struct",
adamc@463	577 space,
adamc@463	578 string "__uws_",
adamc@463	579 string (Int.toString i),
adamc@463	580 space,
adamc@463	581 string "tmp",
adamc@463	582 space,
adamc@463	583 string "=",
adamc@463	584 space,
adamc@463	585 string "{",
adamc@463	586 space,
adamc@463	587 p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
adamc@463	588 string x]) xts,
adamc@463	589 space,
adamc@463	590 string "};",
adamc@463	591 newline,
adamc@463	592 string "tmp;",
adamc@463	593 newline,
adamc@463	594 string "})"]
adamc@463	595 end
adamc@463	596
adamc@463	597 \| TDatatype (Enum, i, _) =>
adamc@463	598 let
adamc@463	599 val (x, xncs) = E.lookupDatatype env i
adamc@463	600
adamc@463	601 fun doEm xncs =
adamc@463	602 case xncs of
adamc@463	603 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
adamc@463	604 ^ x ^ "\"), (enum __uwe_"
adamc@463	605 ^ x ^ "_" ^ Int.toString i ^ ")0)")
adamc@463	606 \| (x', n, to) :: rest =>
adam@1516	607 box [string ("((!strncmp(" ^ request ^ ", \""),
adamc@463	608 string x',
adamc@463	609 string "\", ",
adamc@463	610 string (Int.toString (size x')),
adam@1516	611 string (") && (" ^ request ^ "["),
adamc@463	612 string (Int.toString (size x')),
adam@1516	613 string ("] == 0 \|\| " ^ request ^ "["),
adamc@463	614 string (Int.toString (size x')),
adam@1516	615 string ("] == '/')) ? (" ^ request ^ " += "),
adam@1360	616 string (Int.toString (size x')),
adam@1516	617 string (", (" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"),
adamc@463	618 space,
adamc@463	619 string ":",
adamc@463	620 space,
adamc@463	621 doEm rest,
adamc@463	622 string ")"]
adamc@463	623 in
adamc@463	624 doEm xncs
adamc@463	625 end
adamc@463	626
adamc@463	627 \| TDatatype (Option, i, xncs) =>
adam@1516	628 if IS.member (!unurlifies, i) then
adamc@463	629 box [string "unurlify_",
adamc@463	630 string (Int.toString i),
adam@1545	631 string ("(ctx, " ^ deStar request ^ ")")]
adamc@463	632 else
adamc@463	633 let
adamc@463	634 val (x, _) = E.lookupDatatype env i
adamc@463	635
adamc@463	636 val (no_arg, has_arg, t) =
adamc@463	637 case !xncs of
adamc@463	638 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
adamc@463	639 (no_arg, has_arg, t)
adamc@463	640 \| [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
adamc@463	641 (no_arg, has_arg, t)
adamc@463	642 \| _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
adam@1516	643 in
adam@1516	644 unurlifies := IS.add (!unurlifies, i);
adam@1516	645 addUrlHandler (box [string "static",
adam@1516	646 space,
adam@1516	647 p_typ env t,
adam@1516	648 space,
adam@1516	649 string "*unurlify_",
adam@1516	650 string (Int.toString i),
adam@1546	651 string "(uw_context, char **);",
adam@1546	652 newline],
adam@1546	653 box [string "static",
adam@1546	654 space,
adam@1546	655 p_typ env t,
adam@1546	656 space,
adam@1546	657 string "*unurlify_",
adam@1546	658 string (Int.toString i),
adam@1516	659 string "(uw_context ctx, char **request) {",
adam@1516	660 newline,
adam@1516	661 box [string "return ((request)[0] == '/' ? ++request : *request,",
adam@1516	662 newline,
adam@1516	663 string "((!strncmp(*request, \"",
adam@1516	664 string no_arg,
adam@1516	665 string "\", ",
adam@1516	666 string (Int.toString (size no_arg)),
adam@1516	667 string ") && ((*request)[",
adam@1516	668 string (Int.toString (size no_arg)),
adam@1516	669 string "] == 0 \|\| (*request)[",
adam@1516	670 string (Int.toString (size no_arg)),
adam@1516	671 string "] == '/')) ? (*request",
adam@1516	672 space,
adam@1516	673 string "+=",
adam@1516	674 space,
adam@1516	675 string (Int.toString (size no_arg)),
adam@1516	676 string ", NULL) : ((!strncmp(*request, \"",
adam@1516	677 string has_arg,
adam@1516	678 string "\", ",
adam@1516	679 string (Int.toString (size has_arg)),
adam@1516	680 string ") && ((*request)[",
adam@1516	681 string (Int.toString (size has_arg)),
adam@1516	682 string "] == 0 \|\| (*request)[",
adam@1516	683 string (Int.toString (size has_arg)),
adam@1516	684 string "] == '/')) ? (*request",
adam@1516	685 space,
adam@1516	686 string "+=",
adam@1516	687 space,
adam@1516	688 string (Int.toString (size has_arg)),
adam@1516	689 string ", ((request)[0] == '/' ? ++request : NULL), ",
adam@1516	690 newline,
adam@1516	691
adam@1516	692 if isUnboxable t then
adam@1516	693 unurlify' "(*request)" (#1 t)
adam@1516	694 else
adam@1516	695 box [string "({",
adam@1516	696 newline,
adam@1516	697 p_typ env t,
adam@1516	698 space,
adam@1516	699 string "*tmp",
adam@1516	700 space,
adam@1516	701 string "=",
adam@1516	702 space,
adam@1516	703 string "uw_malloc(ctx, sizeof(",
adam@1516	704 p_typ env t,
adam@1516	705 string "));",
adam@1516	706 newline,
adam@1516	707 string "*tmp",
adam@1516	708 space,
adam@1516	709 string "=",
adam@1516	710 space,
adam@1516	711 unurlify' "(*request)" (#1 t),
adam@1516	712 string ";",
adam@1516	713 newline,
adam@1516	714 string "tmp;",
adam@1516	715 newline,
adam@1516	716 string "})"],
adam@1516	717 string ")",
adam@1516	718 newline,
adam@1516	719 string ":",
adam@1516	720 space,
adam@1516	721 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
adam@1516	722 ^ "\"), NULL))));"),
adam@1516	723 newline],
adam@1516	724 string "}",
adam@1516	725 newline,
adam@1516	726 newline]);
adamc@463	727
adam@1516	728 box [string "unurlify_",
adam@1516	729 string (Int.toString i),
adam@1516	730 string ("(ctx, &" ^ request ^ ")")]
adamc@463	731 end
adamc@463	732
adamc@463	733 \| TDatatype (Default, i, _) =>
adam@1516	734 if IS.member (!unurlifies, i) then
adamc@463	735 box [string "unurlify_",
adamc@463	736 string (Int.toString i),
adam@1545	737 string ("(ctx, " ^ deStar request ^ ")")]
adamc@463	738 else
adamc@463	739 let
adamc@463	740 val (x, xncs) = E.lookupDatatype env i
adamc@463	741
adam@1516	742 val () = unurlifies := IS.add (!unurlifies, i)
adamc@463	743
adamc@463	744 fun doEm xncs =
adamc@463	745 case xncs of
adamc@463	746 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
adamc@463	747 ^ x ^ "\"), NULL)")
adamc@463	748 \| (x', n, to) :: rest =>
adam@1516	749 box [string "((!strncmp(*request, \"",
adamc@463	750 string x',
adamc@463	751 string "\", ",
adamc@463	752 string (Int.toString (size x')),
adam@1516	753 string ") && ((*request)[",
adamc@463	754 string (Int.toString (size x')),
adam@1516	755 string "] == 0 \|\| (*request)[",
adamc@463	756 string (Int.toString (size x')),
adamc@463	757 string "] == '/')) ? ({",
adamc@463	758 newline,
adamc@463	759 string "struct",
adamc@463	760 space,
adamc@463	761 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
adamc@463	762 space,
adamc@463	763 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
adamc@463	764 string x,
adamc@463	765 string "_",
adamc@463	766 string (Int.toString i),
adamc@463	767 string "));",
adamc@463	768 newline,
adamc@463	769 string "tmp->tag",
adamc@463	770 space,
adamc@463	771 string "=",
adamc@463	772 space,
adamc@463	773 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
adamc@463	774 string ";",
adamc@463	775 newline,
adam@1516	776 string "*request",
adamc@463	777 space,
adamc@463	778 string "+=",
adamc@463	779 space,
adamc@463	780 string (Int.toString (size x')),
adamc@463	781 string ";",
adamc@463	782 newline,
adam@1516	783 string "if ((request)[0] == '/') ++request;",
adamc@463	784 newline,
adamc@463	785 case to of
adamc@463	786 NONE => box []
adamc@463	787 \| SOME (t, _) => box [string "tmp->data.uw_",
adamc@463	788 p_ident x',
adamc@463	789 space,
adamc@463	790 string "=",
adamc@463	791 space,
adam@1516	792 unurlify' "(*request)" t,
adamc@463	793 string ";",
adamc@463	794 newline],
adamc@463	795 string "tmp;",
adamc@463	796 newline,
adamc@463	797 string "})",
adamc@463	798 space,
adamc@463	799 string ":",
adamc@463	800 space,
adamc@463	801 doEm rest,
adamc@463	802 string ")"]
adamc@463	803 in
adam@1516	804 addUrlHandler (box [string "static",
adam@1516	805 space,
adam@1516	806 p_typ env (t, ErrorMsg.dummySpan),
adam@1516	807 space,
adam@1516	808 string "unurlify_",
adam@1516	809 string (Int.toString i),
adam@1546	810 string "(uw_context, char **);",
adam@1546	811 newline],
adam@1546	812 box [string "static",
adam@1546	813 space,
adam@1546	814 p_typ env (t, ErrorMsg.dummySpan),
adam@1546	815 space,
adam@1546	816 string "unurlify_",
adam@1546	817 string (Int.toString i),
adam@1516	818 string "(uw_context ctx, char **request) {",
adam@1516	819 newline,
adam@1516	820 box [string "return",
adam@1516	821 space,
adam@1516	822 doEm xncs,
adam@1516	823 string ";",
adam@1516	824 newline],
adam@1516	825 string "}",
adam@1516	826 newline,
adam@1516	827 newline]);
adam@1516	828
adam@1516	829 box [string "unurlify_",
adamc@463	830 string (Int.toString i),
adam@1545	831 string ("(ctx, " ^ deStar request ^ ")")]
adamc@463	832 end
adamc@463	833
adamc@758	834 \| TList (t', i) =>
adam@1516	835 if IS.member (!unurlifies, i) then
adamc@758	836 box [string "unurlify_list_",
adamc@758	837 string (Int.toString i),
adam@1545	838 string ("(ctx, " ^ deStar request ^ ")")]
adamc@758	839 else
adam@1516	840 (unurlifies := IS.add (!unurlifies, i);
adam@1516	841 addUrlHandler (box [string "static",
adam@1516	842 space,
adam@1516	843 p_typ env (t, loc),
adam@1516	844 space,
adam@1516	845 string "unurlify_list_",
adam@1516	846 string (Int.toString i),
adam@1546	847 string "(uw_context, char **);",
adam@1546	848 newline],
adam@1546	849 box [string "static",
adam@1546	850 space,
adam@1546	851 p_typ env (t, loc),
adam@1546	852 space,
adam@1546	853 string "unurlify_list_",
adam@1546	854 string (Int.toString i),
adam@1516	855 string "(uw_context ctx, char **request) {",
adam@1516	856 newline,
adam@1516	857 box [string "return ((request)[0] == '/' ? ++request : *request,",
adam@1516	858 newline,
adam@1516	859 string "((!strncmp(request, \"Nil\", 3) && ((request)[3] == 0 ",
adam@1516	860 string "\|\| (request)[3] == '/')) ? (request",
adam@1516	861 space,
adam@1516	862 string "+=",
adam@1516	863 space,
adam@1547	864 string "3, ((request)[0] == '/' ? ((request)[0] = 0, ++request) : NULL), NULL) : ((!strncmp(request, \"Cons\", 4) && ((*request)[4] == 0 ",
adam@1516	865 string "\|\| (request)[4] == '/')) ? (request",
adam@1516	866 space,
adam@1516	867 string "+=",
adam@1516	868 space,
adam@1516	869 string "4, ((request)[0] == '/' ? ++request : NULL), ",
adam@1516	870 newline,
adam@1516	871
adam@1516	872 string "({",
adam@1516	873 newline,
adam@1516	874 p_typ env (t, loc),
adam@1516	875 space,
adam@1516	876 string "tmp",
adam@1516	877 space,
adam@1516	878 string "=",
adam@1516	879 space,
adam@1516	880 string "uw_malloc(ctx, sizeof(struct __uws_",
adam@1516	881 string (Int.toString i),
adam@1516	882 string "));",
adam@1516	883 newline,
adam@1516	884 string "*tmp",
adam@1516	885 space,
adam@1516	886 string "=",
adam@1516	887 space,
adam@1516	888 unurlify' "(*request)" (TRecord i),
adam@1516	889 string ";",
adam@1516	890 newline,
adam@1516	891 string "tmp;",
adam@1516	892 newline,
adam@1516	893 string "})",
adam@1516	894 string ")",
adam@1516	895 newline,
adam@1516	896 string ":",
adam@1516	897 space,
adam@1516	898 string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"),
adam@1516	899 newline],
adam@1516	900 string "}",
adam@1516	901 newline,
adam@1516	902 newline]);
adamc@758	903
adam@1516	904 box [string "unurlify_list_",
adam@1516	905 string (Int.toString i),
adam@1545	906 string ("(ctx, " ^ deStar request ^ ")")])
adamc@758	907
adamc@471	908 \| TOption t =>
adam@1516	909 box [string ("(" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : " ^ request ^ ", "),
adam@1516	910 string ("((!strncmp(" ^ request ^ ", \"None\", 4) "),
adam@1516	911 string ("&& (" ^ request ^ "[4] == 0 \|\| " ^ request ^ "[4] == '/')) "),
adam@1516	912 string ("? (" ^ request ^ " += (" ^ request ^ "[4] == 0 ? 4 : 5), NULL) "),
adam@1516	913 string (": ((!strncmp(" ^ request ^ ", \"Some\", 4) "),
adam@1516	914 string ("&& " ^ request ^ "[4] == '/') "),
adam@1516	915 string ("? (" ^ request ^ " += 5, "),
adamc@471	916 if isUnboxable t then
adam@1516	917 unurlify' request (#1 t)
adamc@471	918 else
adamc@471	919 box [string "({",
adamc@471	920 newline,
adamc@471	921 p_typ env t,
adamc@471	922 space,
adamc@471	923 string "*tmp",
adamc@471	924 space,
adamc@471	925 string "=",
adamc@471	926 space,
adamc@471	927 string "uw_malloc(ctx, sizeof(",
adamc@471	928 p_typ env t,
adamc@471	929 string "));",
adamc@471	930 newline,
adamc@471	931 string "*tmp",
adamc@471	932 space,
adamc@471	933 string "=",
adamc@471	934 space,
adam@1516	935 unurlify' request (#1 t),
adamc@471	936 string ";",
adamc@471	937 newline,
adamc@471	938 string "tmp;",
adamc@471	939 newline,
adamc@471	940 string "})"],
adamc@471	941 string ") :",
adamc@471	942 space,
adamc@471	943 string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"]
adamc@471	944
adamc@463	945 \| _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@463	946 space)
adamc@463	947 in
adam@1516	948 unurlify' "request" t
adamc@463	949 end
adamc@463	950
adamc@905	951 val urlify1 = ref 0
adamc@905	952
adam@1516	953 val urlifies = ref IS.empty
adam@1516	954 val urlifiesL = ref IS.empty
adam@1516	955
adamc@610	956 fun urlify env t =
adamc@610	957 let
adam@1516	958 fun urlify' level (t as (_, loc)) =
adamc@610	959 case #1 t of
adamc@610	960 TFfi ("Basis", "unit") => box []
adamc@610	961 \| TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
adamc@610	962 ^ "_w(ctx, it" ^ Int.toString level ^ ");"),
adamc@610	963 newline]
adamc@610	964
adamc@610	965 \| TRecord 0 => box []
adamc@610	966 \| TRecord i =>
adamc@610	967 let
adamc@611	968 fun empty (t, _) =
adamc@611	969 case t of
adamc@611	970 TFfi ("Basis", "unit") => true
adamc@611	971 \| TRecord 0 => true
adamc@611	972 \| TRecord j =>
adamc@611	973 List.all (fn (_, t) => empty t) (E.lookupStruct env j)
adamc@611	974 \| _ => false
adamc@611	975
adamc@610	976 val xts = E.lookupStruct env i
adamc@611	977
adamc@613	978 val (blocks, _) = foldl
adamc@613	979 (fn ((x, t), (blocks, printingSinceLastSlash)) =>
adamc@613	980 let
adamc@613	981 val thisEmpty = empty t
adamc@613	982 in
adamc@613	983 if thisEmpty then
adamc@613	984 (blocks, printingSinceLastSlash)
adamc@613	985 else
adamc@613	986 (box [string "{",
adamc@613	987 newline,
adamc@613	988 p_typ env t,
adamc@613	989 space,
adamc@613	990 string ("it" ^ Int.toString (level + 1)),
adamc@613	991 space,
adamc@613	992 string "=",
adamc@613	993 space,
adamc@613	994 string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
adamc@613	995 newline,
adamc@613	996 box (if printingSinceLastSlash then
adamc@613	997 [string "uw_write(ctx, \"/\");",
adamc@613	998 newline]
adamc@613	999 else
adamc@613	1000 []),
adam@1516	1001 urlify' (level + 1) t,
adamc@613	1002 string "}",
adamc@613	1003 newline] :: blocks,
adamc@613	1004 true)
adamc@613	1005 end)
adamc@613	1006 ([], false) xts
adamc@610	1007 in
adamc@613	1008 box (rev blocks)
adamc@610	1009 end
adamc@610	1010
adamc@638	1011 \| TDatatype (Enum, i, _) =>
adamc@638	1012 let
adamc@610	1013 val (x, xncs) = E.lookupDatatype env i
adamc@610	1014
adamc@610	1015 fun doEm xncs =
adamc@610	1016 case xncs of
adamc@638	1017 [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
adamc@638	1018 ^ x ^ "\");"),
adamc@638	1019 newline]
adamc@610	1020 \| (x', n, to) :: rest =>
adamc@638	1021 box [string ("if (it" ^ Int.toString level
adamc@638	1022 ^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"),
adamc@638	1023 newline,
adamc@638	1024 box [string ("uw_write(ctx, \"" ^ x' ^ "\");"),
adamc@638	1025 newline],
adamc@638	1026 string "} else {",
adamc@638	1027 newline,
adamc@638	1028 box [doEm rest,
adamc@638	1029 newline],
adamc@638	1030 string "}"]
adamc@610	1031 in
adamc@610	1032 doEm xncs
adamc@638	1033 end
adamc@610	1034
adamc@639	1035 \| TDatatype (Option, i, xncs) =>
adam@1516	1036 if IS.member (!urlifies, i) then
adamc@639	1037 box [string "urlify_",
adamc@610	1038 string (Int.toString i),
adam@1516	1039 string "(ctx,",
adam@1516	1040 space,
adam@1516	1041 string "it",
adamc@639	1042 string (Int.toString level),
adamc@639	1043 string ");",
adamc@639	1044 newline]
adamc@610	1045 else
adamc@610	1046 let
adamc@610	1047 val (x, _) = E.lookupDatatype env i
adamc@610	1048
adamc@610	1049 val (no_arg, has_arg, t) =
adamc@610	1050 case !xncs of
adamc@610	1051 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
adamc@610	1052 (no_arg, has_arg, t)
adamc@610	1053 \| [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
adamc@610	1054 (no_arg, has_arg, t)
adamc@639	1055 \| _ => raise Fail "CjrPrint: urlify misclassified Option datatype"
adam@1516	1056 in
adam@1516	1057 urlifies := IS.add (!urlifies, i);
adam@1516	1058 addUrlHandler (box [string "static",
adam@1516	1059 space,
adam@1516	1060 string "void",
adam@1516	1061 space,
adam@1516	1062 string "urlify_",
adam@1516	1063 string (Int.toString i),
adam@1546	1064 string "(uw_context,",
adam@1546	1065 space,
adam@1546	1066 p_typ env t,
adam@1546	1067 space,
adam@1546	1068 if isUnboxable t then
adam@1546	1069 box []
adam@1546	1070 else
adam@1546	1071 string "*",
adam@1546	1072 string ");",
adam@1546	1073 newline],
adam@1546	1074 box [string "static",
adam@1546	1075 space,
adam@1546	1076 string "void",
adam@1546	1077 space,
adam@1546	1078 string "urlify_",
adam@1546	1079 string (Int.toString i),
adam@1516	1080 string "(uw_context ctx,",
adam@1516	1081 space,
adam@1516	1082 p_typ env t,
adam@1516	1083 space,
adam@1516	1084 if isUnboxable t then
adam@1516	1085 box []
adam@1516	1086 else
adam@1516	1087 string "*",
adam@1516	1088 string "it0) {",
adam@1516	1089 newline,
adam@1516	1090 box [string "if (it0) {",
adam@1516	1091 newline,
adam@1516	1092 if isUnboxable t then
adam@1516	1093 urlify' 0 t
adam@1516	1094 else
adam@1516	1095 box [p_typ env t,
adam@1516	1096 space,
adam@1516	1097 string "it1",
adam@1516	1098 space,
adam@1516	1099 string "=",
adam@1516	1100 space,
adam@1516	1101 string "*it0;",
adam@1516	1102 newline,
adam@1516	1103 string "uw_write(ctx, \"",
adam@1516	1104 string has_arg,
adam@1516	1105 string "/\");",
adam@1516	1106 newline,
adam@1516	1107 urlify' 1 t,
adam@1516	1108 string ";",
adam@1516	1109 newline],
adam@1516	1110 string "} else {",
adam@1516	1111 box [newline,
adam@1516	1112 string "uw_write(ctx, \"",
adam@1516	1113 string no_arg,
adam@1516	1114 string "\");",
adam@1516	1115 newline],
adam@1516	1116 string "}",
adam@1516	1117 newline],
adam@1516	1118 string "}",
adam@1516	1119 newline,
adam@1516	1120 newline]);
adamc@610	1121
adam@1516	1122 box [string "urlify_",
adam@1516	1123 string (Int.toString i),
adam@1516	1124 string "(ctx,",
adamc@610	1125 space,
adam@1516	1126 string "it",
adamc@639	1127 string (Int.toString level),
adamc@639	1128 string ");",
adamc@639	1129 newline]
adamc@639	1130 end
adamc@610	1131
adamc@640	1132 \| TDatatype (Default, i, _) =>
adam@1516	1133 if IS.member (!urlifies, i) then
adamc@640	1134 box [string "urlify_",
adamc@610	1135 string (Int.toString i),
adam@1516	1136 string "(ctx,",
adam@1516	1137 space,
adam@1516	1138 string "it",
adamc@640	1139 string (Int.toString level),
adamc@640	1140 string ");",
adamc@640	1141 newline]
adamc@610	1142 else
adamc@610	1143 let
adamc@610	1144 val (x, xncs) = E.lookupDatatype env i
adamc@610	1145
adam@1516	1146 val () = urlifies := IS.add (!urlifies, i)
adamc@610	1147
adamc@610	1148 fun doEm xncs =
adamc@610	1149 case xncs of
adamc@640	1150 [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
adamc@640	1151 ^ x ^ " (%d)\", it0->data);"),
adamc@640	1152 newline]
adamc@610	1153 \| (x', n, to) :: rest =>
adamc@640	1154 box [string "if",
adamc@610	1155 space,
adamc@640	1156 string "(it0->tag==__uwc_",
adamc@640	1157 string (ident x'),
adamc@610	1158 string "_",
adamc@640	1159 string (Int.toString n),
adamc@640	1160 string ") {",
adamc@610	1161 newline,
adamc@610	1162 case to of
adamc@640	1163 NONE => box [string "uw_write(ctx, \"",
adamc@640	1164 string x',
adamc@640	1165 string "\");",
adamc@640	1166 newline]
adamc@640	1167 \| SOME t => box [string "uw_write(ctx, \"",
adamc@640	1168 string x',
adamc@640	1169 string "/\");",
adamc@640	1170 newline,
adamc@640	1171 p_typ env t,
adamc@640	1172 space,
adamc@640	1173 string "it1",
adamc@640	1174 space,
adamc@640	1175 string "=",
adamc@640	1176 space,
adamc@640	1177 string "it0->data.uw_",
adamc@640	1178 string x',
adamc@640	1179 string ";",
adamc@640	1180 newline,
adam@1516	1181 urlify' 1 t,
adamc@640	1182 newline],
adamc@640	1183 string "} else {",
adamc@610	1184 newline,
adamc@640	1185 box [doEm rest,
adamc@640	1186 newline],
adamc@640	1187 string "}",
adamc@640	1188 newline]
adamc@610	1189 in
adam@1516	1190 addUrlHandler (box [string "static",
adam@1516	1191 space,
adam@1516	1192 string "void",
adam@1516	1193 space,
adam@1516	1194 string "urlify_",
adam@1516	1195 string (Int.toString i),
adam@1546	1196 string "(uw_context,",
adam@1546	1197 space,
adam@1546	1198 p_typ env t,
adam@1546	1199 string ");",
adam@1546	1200 newline],
adam@1546	1201 box [string "static",
adam@1546	1202 space,
adam@1546	1203 string "void",
adam@1546	1204 space,
adam@1546	1205 string "urlify_",
adam@1546	1206 string (Int.toString i),
adam@1516	1207 string "(uw_context ctx,",
adam@1516	1208 space,
adam@1516	1209 p_typ env t,
adam@1516	1210 space,
adam@1516	1211 string "it0) {",
adam@1516	1212 newline,
adam@1516	1213 box [doEm xncs,
adam@1516	1214 newline],
adam@1516	1215 newline,
adam@1516	1216 string "}",
adam@1516	1217 newline,
adam@1516	1218 newline]);
adam@1516	1219
adam@1516	1220 box [string "urlify_",
adam@1516	1221 string (Int.toString i),
adam@1516	1222 string "(ctx,",
adamc@610	1223 space,
adam@1516	1224 string "it",
adamc@640	1225 string (Int.toString level),
adamc@640	1226 string ");",
adamc@640	1227 newline]
adamc@640	1228 end
adamc@610	1229
adamc@641	1230 \| TOption t =>
adamc@641	1231 box [string "if (it",
adamc@641	1232 string (Int.toString level),
adamc@641	1233 string ") {",
adamc@641	1234 if isUnboxable t then
adamc@641	1235 box [string "uw_write(ctx, \"Some/\");",
adamc@641	1236 newline,
adam@1516	1237 urlify' level t]
adamc@610	1238 else
adamc@641	1239 box [p_typ env t,
adamc@610	1240 space,
adamc@641	1241 string "it",
adamc@641	1242 string (Int.toString (level + 1)),
adamc@610	1243 space,
adamc@610	1244 string "=",
adamc@610	1245 space,
adamc@641	1246 string "*it",
adamc@641	1247 string (Int.toString level),
adamc@610	1248 string ";",
adamc@610	1249 newline,
adamc@641	1250 string "uw_write(ctx, \"Some/\");",
adamc@610	1251 newline,
adam@1516	1252 urlify' (level + 1) t,
adamc@641	1253 string ";",
adamc@641	1254 newline],
adamc@641	1255 string "} else {",
adamc@905	1256 box [newline,
adamc@905	1257 string "uw_write(ctx, \"None\");",
adamc@641	1258 newline],
adamc@641	1259 string "}",
adamc@641	1260 newline]
adamc@610	1261
adamc@905	1262 \| TList (t, i) =>
adam@1516	1263 if IS.member (!urlifiesL, i) then
adamc@905	1264 box [string "urlifyl_",
adamc@905	1265 string (Int.toString i),
adam@1516	1266 string "(ctx,",
adam@1516	1267 space,
adam@1516	1268 string "it",
adamc@905	1269 string (Int.toString level),
adamc@905	1270 string ");",
adamc@905	1271 newline]
adamc@905	1272 else
adam@1516	1273 (urlifiesL := IS.add (!urlifiesL, i);
adam@1516	1274 addUrlHandler (box [string "static",
adam@1516	1275 space,
adam@1516	1276 string "void",
adam@1516	1277 space,
adam@1516	1278 string "urlifyl_",
adam@1516	1279 string (Int.toString i),
adam@1546	1280 string "(uw_context,",
adam@1546	1281 space,
adam@1546	1282 string "struct __uws_",
adam@1546	1283 string (Int.toString i),
adam@1546	1284 space,
adam@1546	1285 string "*);",
adam@1546	1286 newline],
adam@1546	1287 box [string "static",
adam@1546	1288 space,
adam@1546	1289 string "void",
adam@1546	1290 space,
adam@1546	1291 string "urlifyl_",
adam@1546	1292 string (Int.toString i),
adam@1516	1293 string "(uw_context ctx,",
adam@1516	1294 space,
adam@1516	1295 string "struct __uws_",
adam@1516	1296 string (Int.toString i),
adam@1516	1297 space,
adam@1516	1298 string "*it0) {",
adam@1516	1299 newline,
adam@1516	1300 box [string "if (it0) {",
adam@1516	1301 newline,
adam@1516	1302 p_typ env t,
adam@1516	1303 space,
adam@1516	1304 string "it1",
adam@1516	1305 space,
adam@1516	1306 string "=",
adam@1516	1307 space,
adam@1516	1308 string "it0->__uwf_1;",
adam@1516	1309 newline,
adam@1516	1310 string "uw_write(ctx, \"Cons/\");",
adam@1516	1311 newline,
adam@1516	1312 urlify' 1 t,
adam@1516	1313 string ";",
adam@1516	1314 newline,
adam@1516	1315 string "uw_write(ctx, \"/\");",
adam@1516	1316 newline,
adam@1516	1317 string "urlifyl_",
adam@1516	1318 string (Int.toString i),
adam@1516	1319 string "(ctx, it0->__uwf_2);",
adam@1516	1320 newline,
adam@1516	1321 string "} else {",
adam@1516	1322 newline,
adam@1516	1323 box [string "uw_write(ctx, \"Nil\");",
adam@1516	1324 newline],
adam@1516	1325 string "}",
adam@1516	1326 newline],
adam@1516	1327 string "}",
adam@1516	1328 newline,
adam@1516	1329 newline]);
adamc@905	1330
adam@1516	1331 box [string "urlifyl_",
adam@1516	1332 string (Int.toString i),
adam@1516	1333 string "(ctx,",
adam@1516	1334 space,
adam@1516	1335 string "it",
adam@1516	1336 string (Int.toString level),
adam@1516	1337 string ");",
adam@1516	1338 newline])
adam@1516	1339
adamc@610	1340 \| _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
adamc@610	1341 space)
adamc@610	1342 in
adam@1516	1343 urlify' 0 t
adamc@610	1344 end
adamc@610	1345
adamc@867	1346 fun sql_type_in env (tAll as (t, loc)) =
adamc@867	1347 case t of
adamc@867	1348 TFfi ("Basis", "int") => Int
adamc@867	1349 \| TFfi ("Basis", "float") => Float
adamc@867	1350 \| TFfi ("Basis", "string") => String
adamc@1011	1351 \| TFfi ("Basis", "char") => Char
adamc@867	1352 \| TFfi ("Basis", "bool") => Bool
adamc@867	1353 \| TFfi ("Basis", "time") => Time
adamc@867	1354 \| TFfi ("Basis", "blob") => Blob
adamc@867	1355 \| TFfi ("Basis", "channel") => Channel
adamc@867	1356 \| TFfi ("Basis", "client") => Client
adamc@867	1357 \| TOption t' => Nullable (sql_type_in env t')
adamc@867	1358 \| _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
adamc@867	1359 Print.eprefaces' [("Type", p_typ env tAll)];
adamc@867	1360 Int)
adamc@867	1361
adam@1391	1362 fun potentiallyFancy (e, _) =
adam@1391	1363 case e of
adam@1391	1364 EPrim _ => false
adam@1391	1365 \| ERel _ => false
adam@1391	1366 \| ENamed _ => false
adam@1391	1367 \| ECon (_, _, NONE) => false
adam@1391	1368 \| ECon (_, _, SOME e) => potentiallyFancy e
adam@1391	1369 \| ENone _ => false
adam@1391	1370 \| ESome (_, e) => potentiallyFancy e
adam@1391	1371 \| EFfi _ => false
adam@1391	1372 \| EFfiApp _ => true
adam@1391	1373 \| EApp _ => true
adam@1391	1374 \| EUnop (_, e) => potentiallyFancy e
adam@1391	1375 \| EBinop (_, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391	1376 \| ERecord (_, xes) => List.exists (potentiallyFancy o #2) xes
adam@1391	1377 \| EField (e, _) => potentiallyFancy e
adam@1391	1378 \| ECase (e, pes, _) => potentiallyFancy e orelse List.exists (potentiallyFancy o #2) pes
adam@1391	1379 \| EError _ => false
adam@1391	1380 \| EReturnBlob _ => false
adam@1391	1381 \| ERedirect _ => false
adam@1391	1382 \| EWrite e => potentiallyFancy e
adam@1391	1383 \| ESeq (e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391	1384 \| ELet (_, _, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391	1385 \| EQuery _ => true
adam@1391	1386 \| EDml {dml = e, ...} => potentiallyFancy e
adam@1391	1387 \| ENextval {seq = e, ...} => potentiallyFancy e
adam@1391	1388 \| ESetval {seq = e1, count = e2} => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391	1389 \| EUnurlify _ => true
adam@1391	1390
adam@1524	1391 val self = ref (NONE : int option)
adam@1524	1392
adam@1524	1393 fun p_exp' par tail env (e, loc) =
adamc@29	1394 case e of
adamc@276	1395 EPrim p => Prim.p_t_GCC p
adamc@29	1396 \| ERel n => p_rel env n
adamc@109	1397 \| ENamed n => p_enamed env n
adamc@188	1398 \| ECon (Enum, pc, _) => p_patCon env pc
adamc@198	1399 \| ECon (Option, pc, NONE) => string "NULL"
adamc@198	1400 \| ECon (Option, pc, SOME e) =>
adamc@198	1401 let
adamc@198	1402 val to = case pc of
adamc@198	1403 PConVar n => #2 (E.lookupConstructor env n)
adamc@198	1404 \| PConFfi {arg, ...} => arg
adamc@198	1405
adamc@198	1406 val t = case to of
adamc@198	1407 NONE => raise Fail "CjrPrint: ECon argument status mismatch"
adamc@198	1408 \| SOME t => t
adamc@198	1409 in
adamc@463	1410 if isUnboxable t then
adam@1524	1411 p_exp' par tail env e
adamc@463	1412 else
adamc@463	1413 box [string "({",
adamc@463	1414 newline,
adamc@463	1415 p_typ env t,
adamc@463	1416 space,
adamc@463	1417 string "*tmp",
adamc@463	1418 space,
adamc@463	1419 string "=",
adamc@463	1420 space,
adamc@463	1421 string "uw_malloc(ctx, sizeof(",
adamc@463	1422 p_typ env t,
adamc@463	1423 string "));",
adamc@463	1424 newline,
adamc@463	1425 string "*tmp",
adamc@463	1426 space,
adamc@463	1427 string "=",
adam@1516	1428 space,
adam@1524	1429 p_exp' par false env e,
adamc@463	1430 string ";",
adamc@463	1431 newline,
adamc@463	1432 string "tmp;",
adamc@463	1433 newline,
adamc@463	1434 string "})"]
adamc@198	1435 end
adamc@188	1436 \| ECon (Default, pc, eo) =>
adamc@181	1437 let
adamc@196	1438 val (xd, xc, xn) = patConInfo env pc
adamc@181	1439 in
adamc@182	1440 box [string "({",
adamc@181	1441 newline,
adamc@181	1442 string "struct",
adamc@181	1443 space,
adamc@185	1444 string xd,
adamc@181	1445 space,
adamc@181	1446 string "*tmp",
adamc@181	1447 space,
adamc@181	1448 string "=",
adamc@181	1449 space,
adamc@311	1450 string "uw_malloc(ctx, sizeof(struct ",
adamc@185	1451 string xd,
adamc@181	1452 string "));",
adamc@181	1453 newline,
adamc@181	1454 string "tmp->tag",
adamc@181	1455 space,
adamc@181	1456 string "=",
adamc@181	1457 space,
adamc@185	1458 string xc,
adamc@181	1459 string ";",
adamc@181	1460 newline,
adamc@181	1461 case eo of
adamc@181	1462 NONE => box []
adamc@185	1463 \| SOME e => box [string "tmp->data.",
adamc@196	1464 string xn,
adamc@181	1465 space,
adamc@181	1466 string "=",
adamc@181	1467 space,
adam@1524	1468 p_exp' false false env e,
adamc@181	1469 string ";",
adamc@181	1470 newline],
adamc@181	1471 string "tmp;",
adamc@181	1472 newline,
adamc@181	1473 string "})"]
adamc@181	1474 end
adamc@297	1475 \| ENone _ => string "NULL"
adamc@290	1476 \| ESome (t, e) =>
adamc@463	1477 if isUnboxable t then
adam@1524	1478 p_exp' par tail env e
adamc@463	1479 else
adamc@463	1480 box [string "({",
adamc@463	1481 newline,
adamc@463	1482 p_typ env t,
adamc@463	1483 space,
adamc@463	1484 string "*tmp",
adamc@463	1485 space,
adamc@463	1486 string "=",
adamc@463	1487 space,
adamc@463	1488 string "uw_malloc(ctx, sizeof(",
adamc@463	1489 p_typ env t,
adamc@463	1490 string "));",
adamc@463	1491 newline,
adamc@463	1492 string "*tmp",
adamc@463	1493 space,
adamc@463	1494 string "=",
adam@1516	1495 space,
adam@1524	1496 p_exp' par false env e,
adamc@463	1497 string ";",
adamc@463	1498 newline,
adamc@463	1499 string "tmp;",
adamc@463	1500 newline,
adamc@463	1501 string "})"]
adamc@109	1502
adamc@316	1503 \| EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
adamc@283	1504 \| EError (e, t) =>
adamc@283	1505 box [string "({",
adamc@283	1506 newline,
adamc@283	1507 p_typ env t,
adamc@283	1508 space,
adamc@283	1509 string "tmp;",
adamc@283	1510 newline,
adamc@311	1511 string "uw_error(ctx, FATAL, \"",
adamc@292	1512 string (ErrorMsg.spanToString loc),
adamc@292	1513 string ": %s\", ",
adam@1524	1514 p_exp' false false env e,
adamc@283	1515 string ");",
adamc@283	1516 newline,
adamc@283	1517 string "tmp;",
adamc@283	1518 newline,
adamc@283	1519 string "})"]
adamc@741	1520 \| EReturnBlob {blob, mimeType, t} =>
adamc@741	1521 box [string "({",
adamc@741	1522 newline,
adamc@741	1523 p_typ env t,
adamc@741	1524 space,
adamc@741	1525 string "tmp;",
adamc@741	1526 newline,
adamc@741	1527 string "uw_return_blob(ctx, ",
adam@1524	1528 p_exp' false false env blob,
adamc@741	1529 string ", ",
adam@1524	1530 p_exp' false false env mimeType,
adamc@741	1531 string ");",
adamc@741	1532 newline,
adamc@741	1533 string "tmp;",
adamc@741	1534 newline,
adamc@741	1535 string "})"]
adamc@1065	1536 \| ERedirect (e, t) =>
adamc@1065	1537 box [string "({",
adamc@1065	1538 newline,
adamc@1065	1539 p_typ env t,
adamc@1065	1540 space,
adamc@1065	1541 string "tmp;",
adamc@1065	1542 newline,
adamc@1065	1543 string "uw_redirect(ctx, ",
adam@1524	1544 p_exp' false false env e,
adamc@1065	1545 string ");",
adamc@1065	1546 newline,
adamc@1065	1547 string "tmp;",
adamc@1065	1548 newline,
adamc@1065	1549 string "})"]
adamc@476	1550 \| EApp ((EError (e, (TFun (_, ran), _)), loc), _) =>
adam@1524	1551 p_exp' false false env (EError (e, ran), loc)
adamc@741	1552 \| EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
adam@1524	1553 p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
adamc@476	1554
adamc@922	1555 \| EFfiApp ("Basis", "strcat", [e1, e2]) =>
adamc@922	1556 let
adamc@922	1557 fun flatten e =
adamc@922	1558 case #1 e of
adamc@922	1559 EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2
adamc@922	1560 \| _ => [e]
adamc@922	1561 in
adamc@922	1562 case flatten e1 @ flatten e2 of
adamc@922	1563 [e1, e2] => box [string "uw_Basis_strcat(ctx, ",
adam@1524	1564 p_exp' false false env e1,
adamc@922	1565 string ",",
adam@1524	1566 p_exp' false false env e2,
adamc@922	1567 string ")"]
adamc@922	1568 \| es => box [string "uw_Basis_mstrcat(ctx, ",
adam@1524	1569 p_list (p_exp' false false env) es,
adamc@922	1570 string ", NULL)"]
adamc@922	1571 end
adamc@922	1572
adamc@765	1573 \| EFfiApp (m, x, []) => box [string "uw_",
adamc@765	1574 p_ident m,
adamc@765	1575 string "_",
adamc@765	1576 p_ident x,
adamc@765	1577 string "(ctx)"]
adamc@765	1578
adamc@311	1579 \| EFfiApp (m, x, es) => box [string "uw_",
adamc@316	1580 p_ident m,
adamc@53	1581 string "_",
adamc@316	1582 p_ident x,
adamc@117	1583 string "(ctx, ",
adam@1524	1584 p_list (p_exp' false false env) es,
adamc@53	1585 string ")"]
adamc@316	1586 \| EApp (f, args) =>
adam@1524	1587 let
adam@1524	1588 fun default () = parenIf par (box [p_exp' true false env f,
adam@1524	1589 string "(ctx,",
adam@1524	1590 space,
adam@1524	1591 p_list_sep (box [string ",", space]) (p_exp' false false env) args,
adam@1524	1592 string ")"])
adam@1524	1593
adam@1524	1594 fun isSelf n =
adam@1524	1595 let
adam@1524	1596 val (_, t) = E.lookupENamed env n
adam@1524	1597
adam@1524	1598 fun getSig (t, args) =
adam@1524	1599 case #1 t of
adam@1524	1600 TFun (dom, t) => getSig (t, dom :: args)
adam@1524	1601 \| _ => (args, t)
adam@1524	1602
adam@1524	1603 val (argts, ret) = getSig (t, [])
adam@1524	1604 in
adam@1524	1605 parenIf par (box [string "({",
adam@1524	1606 newline,
adam@1524	1607 p_list_sepi newline
adam@1524	1608 (fn i => fn (e, t) =>
adam@1524	1609 box [p_typ env t,
adam@1524	1610 space,
adam@1524	1611 string ("rearg" ^ Int.toString i),
adam@1524	1612 space,
adam@1524	1613 string "=",
adam@1524	1614 space,
adam@1524	1615 p_exp' false false env e,
adam@1524	1616 string ";"])
adam@1524	1617 (ListPair.zip (args, argts)),
adam@1524	1618 newline,
adam@1524	1619 p_typ env ret,
adam@1524	1620 space,
adam@1524	1621 string "tmp;",
adam@1524	1622 newline,
adam@1524	1623 p_list_sepi newline
adam@1524	1624 (fn i => fn _ =>
adam@1524	1625 box [p_rel env (E.countERels env - 1 - i),
adam@1524	1626 space,
adam@1524	1627 string "=",
adam@1524	1628 space,
adam@1524	1629 string ("rearg" ^ Int.toString i ^ ";")]) args,
adam@1524	1630 newline,
adam@1524	1631 string "goto restart;",
adam@1524	1632 newline,
adam@1524	1633 string "tmp;",
adam@1524	1634 newline,
adam@1524	1635 string "})"])
adam@1524	1636 end
adam@1524	1637 in
adam@1524	1638 case #1 f of
adam@1524	1639 ENamed n => if SOME n = !self andalso tail then
adam@1524	1640 isSelf n
adam@1524	1641 else
adam@1524	1642 default ()
adam@1524	1643 \| _ => default ()
adam@1524	1644 end
adamc@29	1645
adamc@387	1646 \| EUnop (s, e1) =>
adamc@387	1647 parenIf par (box [string s,
adamc@387	1648 space,
adam@1524	1649 p_exp' true false env e1])
adamc@387	1650
adamc@387	1651 \| EBinop (s, e1, e2) =>
adamc@389	1652 if Char.isAlpha (String.sub (s, size s - 1)) then
adamc@389	1653 box [string s,
adamc@390	1654 string "(",
adam@1524	1655 p_exp' false false env e1,
adamc@389	1656 string ",",
adamc@389	1657 space,
adam@1524	1658 p_exp' false false env e2,
adamc@389	1659 string ")"]
adamc@389	1660 else
adam@1524	1661 parenIf par (box [p_exp' true false env e1,
adamc@389	1662 space,
adamc@389	1663 string s,
adamc@389	1664 space,
adam@1524	1665 p_exp' true false env e2])
adamc@387	1666
adam@1431	1667 \| ERecord (0, _) => string "0"
adam@1431	1668
adamc@29	1669 \| ERecord (i, xes) => box [string "({",
adamc@29	1670 space,
adamc@29	1671 string "struct",
adamc@29	1672 space,
adamc@311	1673 string ("__uws_" ^ Int.toString i),
adamc@29	1674 space,
adamc@181	1675 string "tmp",
adamc@29	1676 space,
adamc@29	1677 string "=",
adamc@29	1678 space,
adamc@29	1679 string "{",
adamc@29	1680 p_list (fn (_, e) =>
adam@1524	1681 p_exp' false false env e) xes,
adamc@29	1682 string "};",
adamc@29	1683 space,
adamc@181	1684 string "tmp;",
adamc@29	1685 space,
adamc@29	1686 string "})" ]
adamc@29	1687 \| EField (e, x) =>
adam@1524	1688 box [p_exp' true false env e,
adamc@311	1689 string ".__uwf_",
adamc@316	1690 p_ident x]
adamc@29	1691
adamc@182	1692 \| ECase (e, pes, {disc, result}) =>
adam@1431	1693 box [string "({",
adam@1431	1694 newline,
adam@1431	1695 p_typ env disc,
adam@1431	1696 space,
adam@1431	1697 string "disc",
adam@1431	1698 space,
adam@1431	1699 string "=",
adam@1431	1700 space,
adam@1524	1701 p_exp' false false env e,
adam@1431	1702 string ";",
adam@1431	1703 newline,
adam@1431	1704 newline,
adam@1431	1705 foldr (fn ((p, e), body) =>
adam@1431	1706 let
adam@1431	1707 val pm = p_patMatch (env, "disc") p
adam@1516	1708 val (pb, env') = p_patBind (env, "disc") p
adam@1431	1709 in
adam@1431	1710 box [pm,
adam@1431	1711 space,
adam@1431	1712 string "?",
adam@1431	1713 space,
adam@1516	1714 if E.countERels env' = E.countERels env then
adam@1524	1715 p_exp' false tail env e
adam@1516	1716 else
adam@1516	1717 box [string "({",
adam@1516	1718 pb,
adam@1524	1719 p_exp' false tail env' e,
adam@1516	1720 string ";",
adam@1516	1721 newline,
adam@1516	1722 string "})"],
adam@1431	1723 newline,
adam@1431	1724 space,
adam@1431	1725 string ":",
adam@1431	1726 space,
adam@1431	1727 body]
adam@1431	1728 end) (box [string "({",
adam@1431	1729 newline,
adam@1431	1730 p_typ env result,
adam@1431	1731 space,
adam@1431	1732 string "tmp;",
adam@1431	1733 newline,
adam@1431	1734 string "uw_error(ctx, FATAL, \"",
adam@1431	1735 string (ErrorMsg.spanToString loc),
adam@1431	1736 string ": pattern match failure\");",
adam@1431	1737 newline,
adam@1431	1738 string "tmp;",
adam@1431	1739 newline,
adam@1431	1740 string "})"]) pes,
adam@1431	1741 string ";",
adam@1431	1742 newline,
adam@1431	1743 string "})"]
adamc@181	1744
adamc@311	1745 \| EWrite e => box [string "(uw_write(ctx, ",
adam@1524	1746 p_exp' false false env e,
adam@1431	1747 string "), 0)"]
adamc@102	1748
adam@1391	1749 \| ESeq (e1, e2) =>
adam@1391	1750 let
adam@1391	1751 val useRegion = potentiallyFancy e1
adam@1391	1752 in
adam@1391	1753 box [string "(",
adam@1391	1754 if useRegion then
adam@1391	1755 box [string "uw_begin_region(ctx),",
adam@1391	1756 space]
adam@1391	1757 else
adam@1391	1758 box [],
adam@1524	1759 p_exp' false false env e1,
adam@1391	1760 string ",",
adam@1391	1761 space,
adam@1391	1762 if useRegion then
adam@1391	1763 box [string "uw_end_region(ctx),",
adam@1391	1764 space]
adam@1391	1765 else
adam@1391	1766 box [],
adam@1524	1767 p_exp' false tail env e2,
adam@1391	1768 string ")"]
adam@1391	1769 end
adam@1391	1770 \| ELet (x, t, e1, e2) =>
adam@1391	1771 let
adam@1391	1772 val useRegion = notLeaky env false t andalso potentiallyFancy e1
adam@1391	1773 in
adam@1391	1774 box [string "({",
adam@1391	1775 newline,
adam@1391	1776 p_typ env t,
adam@1391	1777 space,
adam@1391	1778 string "__uwr_",
adam@1391	1779 p_ident x,
adam@1391	1780 string "_",
adam@1391	1781 string (Int.toString (E.countERels env)),
adam@1391	1782 space,
adam@1391	1783 string "=",
adam@1391	1784 space,
adam@1391	1785 if useRegion then
adam@1391	1786 box [string "(uw_begin_region(ctx),",
adam@1391	1787 space]
adam@1391	1788 else
adam@1391	1789 box [],
adam@1524	1790 p_exp' false false env e1,
adam@1391	1791 if useRegion then
adam@1391	1792 string ")"
adam@1391	1793 else
adam@1391	1794 box [],
adam@1391	1795 string ";",
adam@1391	1796 newline,
adam@1391	1797 if useRegion then
adam@1391	1798 box [string "uw_end_region(ctx);",
adam@1391	1799 newline]
adam@1391	1800 else
adam@1391	1801 box [],
adam@1524	1802 p_exp' false tail (E.pushERel env x t) e2,
adam@1391	1803 string ";",
adam@1391	1804 newline,
adam@1391	1805 string "})"]
adam@1391	1806 end
adamc@269	1807
adamc@282	1808 \| EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
adamc@278	1809 let
adamc@316	1810 val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps
adamc@278	1811 val tables = ListUtil.mapConcat (fn (x, xts) =>
adamc@316	1812 map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
adamc@278	1813 tables
adamc@638	1814
adamc@1168	1815 val sort = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
adamc@1168	1816 val outputs = sort exps @ sort tables
adamc@324	1817
adamc@324	1818 val wontLeakStrings = notLeaky env true state
adamc@324	1819 val wontLeakAnything = notLeaky env false state
adamc@867	1820
adamc@867	1821 val inputs =
adamc@867	1822 case prepared of
adamc@867	1823 NONE => []
adamc@867	1824 \| SOME _ => getPargs query
adamc@867	1825
adamc@867	1826 fun doCols p_getcol =
adamc@867	1827 box [string "struct __uws_",
adamc@867	1828 string (Int.toString rnum),
adamc@867	1829 string " __uwr_r_",
adamc@867	1830 string (Int.toString (E.countERels env)),
adamc@867	1831 string ";",
adamc@867	1832 newline,
adamc@867	1833 p_typ env state,
adamc@867	1834 space,
adamc@867	1835 string "__uwr_acc_",
adamc@867	1836 string (Int.toString (E.countERels env + 1)),
adamc@867	1837 space,
adamc@867	1838 string "=",
adamc@867	1839 space,
adamc@867	1840 string "acc;",
adamc@867	1841 newline,
adamc@867	1842 newline,
adamc@1114	1843
adamc@1114	1844 if Settings.getDeadlines () then
adamc@1114	1845 box [string "uw_check_deadline(ctx);",
adamc@1114	1846 newline]
adamc@1114	1847 else
adamc@1114	1848 box [],
adamc@1114	1849
adamc@867	1850 p_list_sepi (box []) (fn i =>
adamc@867	1851 fn (proj, t) =>
adamc@867	1852 box [string "__uwr_r_",
adamc@867	1853 string (Int.toString (E.countERels env)),
adamc@867	1854 string ".",
adamc@867	1855 string proj,
adamc@867	1856 space,
adamc@867	1857 string "=",
adamc@867	1858 space,
adamc@880	1859 p_getcol {loc = loc,
adamc@880	1860 wontLeakStrings = wontLeakStrings,
adamc@867	1861 col = i,
adamc@867	1862 typ = sql_type_in env t},
adamc@867	1863 string ";",
adamc@867	1864 newline]) outputs,
adamc@867	1865 newline,
adamc@867	1866 newline,
adamc@867	1867
adamc@867	1868 string "acc",
adamc@867	1869 space,
adamc@867	1870 string "=",
adamc@867	1871 space,
adam@1524	1872 p_exp' false false (E.pushERel
adam@1524	1873 (E.pushERel env "r" (TRecord rnum, loc))
adam@1524	1874 "acc" state)
adam@1524	1875 body,
adamc@867	1876 string ";",
adamc@867	1877 newline]
adamc@278	1878 in
adamc@640	1879 box [if wontLeakAnything then
adamc@704	1880 string "(uw_begin_region(ctx), "
adamc@324	1881 else
adamc@324	1882 box [],
adamc@324	1883 string "({",
adamc@278	1884 newline,
adamc@640	1885 p_typ env state,
adamc@640	1886 space,
adamc@640	1887 string "acc",
adamc@640	1888 space,
adamc@640	1889 string "=",
adamc@640	1890 space,
adam@1524	1891 p_exp' false false env initial,
adamc@640	1892 string ";",
adamc@640	1893 newline,
adamc@867	1894 string "int dummy = (uw_begin_region(ctx), 0);",
adamc@640	1895 newline,
adamc@640	1896
adamc@282	1897 case prepared of
adamc@867	1898 NONE =>
adamc@867	1899 box [string "char *query = ",
adam@1524	1900 p_exp' false false env query,
adamc@867	1901 string ";",
adamc@867	1902 newline,
adamc@867	1903 newline,
adamc@282	1904
adamc@867	1905 #query (Settings.currentDbms ())
adamc@867	1906 {loc = loc,
adamc@873	1907 cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@867	1908 doCols = doCols}]
adamc@879	1909 \| SOME {id, query, nested} =>
adamc@867	1910 box [p_list_sepi newline
adamc@867	1911 (fn i => fn (e, t) =>
adamc@867	1912 box [p_sql_type t,
adamc@867	1913 space,
adamc@867	1914 string "arg",
adamc@867	1915 string (Int.toString (i + 1)),
adamc@867	1916 space,
adamc@867	1917 string "=",
adamc@867	1918 space,
adam@1524	1919 p_exp' false false env e,
adamc@867	1920 string ";"])
adamc@867	1921 inputs,
adamc@867	1922 newline,
adamc@867	1923 newline,
adamc@640	1924
adamc@867	1925 #queryPrepared (Settings.currentDbms ())
adamc@867	1926 {loc = loc,
adamc@867	1927 id = id,
adamc@867	1928 query = query,
adamc@867	1929 inputs = map #2 inputs,
adamc@873	1930 cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@879	1931 doCols = doCols,
adamc@879	1932 nested = nested}],
adamc@278	1933 newline,
adamc@277	1934
adamc@324	1935 if wontLeakAnything then
adamc@324	1936 box [string "uw_end_region(ctx);",
adamc@324	1937 newline]
adamc@324	1938 else
adamc@324	1939 box [],
adamc@278	1940 string "acc;",
adamc@278	1941 newline,
adamc@704	1942 string "})",
adamc@704	1943 if wontLeakAnything then
adamc@704	1944 string ")"
adamc@704	1945 else
adamc@704	1946 box []]
adamc@278	1947 end
adamc@106	1948
adam@1293	1949 \| EDml {dml, prepared, mode} =>
adam@1295	1950 box [string "(uw_begin_region(ctx), ({",
adamc@307	1951 newline,
adamc@307	1952 case prepared of
adamc@307	1953 NONE => box [string "char *dml = ",
adam@1524	1954 p_exp' false false env dml,
adamc@307	1955 string ";",
adamc@868	1956 newline,
adamc@868	1957 newline,
adam@1293	1958 #dml (Settings.currentDbms ()) (loc, mode)]
adamc@879	1959 \| SOME {id, dml = dml'} =>
adamc@307	1960 let
adamc@868	1961 val inputs = getPargs dml
adamc@307	1962 in
adamc@307	1963 box [p_list_sepi newline
adamc@307	1964 (fn i => fn (e, t) =>
adamc@307	1965 box [p_sql_type t,
adamc@307	1966 space,
adamc@307	1967 string "arg",
adamc@307	1968 string (Int.toString (i + 1)),
adamc@307	1969 space,
adamc@307	1970 string "=",
adamc@307	1971 space,
adam@1524	1972 p_exp' false false env e,
adamc@307	1973 string ";"])
adamc@868	1974 inputs,
adamc@307	1975 newline,
adamc@307	1976 newline,
adamc@307	1977
adamc@868	1978 #dmlPrepared (Settings.currentDbms ()) {loc = loc,
adamc@868	1979 id = id,
adamc@868	1980 dml = dml',
adam@1293	1981 inputs = map #2 inputs,
adam@1293	1982 mode = mode}]
adamc@307	1983 end,
adamc@307	1984 newline,
adamc@307	1985 newline,
adamc@337	1986 string "uw_end_region(ctx);",
adamc@337	1987 newline,
adam@1293	1988
adam@1293	1989 case mode of
adam@1431	1990 Settings.Error => string "0;"
adam@1295	1991 \| Settings.None => string "uw_dup_and_clear_error_message(ctx);",
adam@1293	1992
adamc@307	1993 newline,
adam@1295	1994 string "}))"]
adamc@307	1995
adamc@338	1996 \| ENextval {seq, prepared} =>
adamc@878	1997 box [string "({",
adamc@878	1998 newline,
adamc@878	1999 string "uw_Basis_int n;",
adamc@878	2000 newline,
adamc@869	2001
adamc@878	2002 case prepared of
adamc@878	2003 NONE => #nextval (Settings.currentDbms ()) {loc = loc,
adam@1524	2004 seqE = p_exp' false false env seq,
adamc@878	2005 seqName = case #1 seq of
adamc@878	2006 EPrim (Prim.String s) => SOME s
adamc@878	2007 \| _ => NONE}
adamc@879	2008 \| SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
adamc@878	2009 id = id,
adamc@878	2010 query = query},
adamc@878	2011 newline,
adamc@878	2012 newline,
adamc@869	2013
adamc@878	2014 string "n;",
adamc@878	2015 newline,
adamc@878	2016 string "})"]
adamc@338	2017
adamc@1073	2018 \| ESetval {seq, count} =>
adamc@1073	2019 box [string "({",
adamc@1073	2020 newline,
adamc@1073	2021
adamc@1073	2022 #setval (Settings.currentDbms ()) {loc = loc,
adam@1524	2023 seqE = p_exp' false false env seq,
adam@1524	2024 count = p_exp' false false env count},
adamc@1073	2025 newline,
adamc@1073	2026 newline,
adamc@1073	2027
adam@1431	2028 string "0;",
adamc@1073	2029 newline,
adamc@1073	2030 string "})"]
adamc@1073	2031
adamc@1112	2032 \| EUnurlify (e, t, true) =>
adamc@463	2033 let
adamc@463	2034 fun getIt () =
adamc@463	2035 if isUnboxable t then
adamc@1023	2036 unurlify false env t
adamc@463	2037 else
adamc@463	2038 box [string "({",
adamc@463	2039 newline,
adamc@463	2040 p_typ env t,
adamc@463	2041 string " *tmp = uw_malloc(ctx, sizeof(",
adamc@463	2042 p_typ env t,
adamc@463	2043 string "));",
adamc@463	2044 newline,
adamc@463	2045 string "*tmp = ",
adamc@1023	2046 unurlify false env t,
adamc@463	2047 string ";",
adamc@463	2048 newline,
adamc@463	2049 string "tmp;",
adamc@463	2050 newline,
adamc@463	2051 string "})"]
adamc@463	2052 in
adamc@463	2053 box [string "({",
adamc@463	2054 newline,
adamc@737	2055 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
adam@1524	2056 p_exp' false false env e,
adamc@492	2057 string ");",
adamc@463	2058 newline,
adamc@463	2059 newline,
adamc@463	2060 string "(request ? ",
adamc@463	2061 getIt (),
adamc@463	2062 string " : NULL);",
adamc@463	2063 newline,
adamc@463	2064 string "})"]
adamc@463	2065 end
adamc@463	2066
adamc@1112	2067 \| EUnurlify (e, t, false) =>
adamc@1112	2068 let
adamc@1112	2069 fun getIt () =
adamc@1112	2070 if isUnboxable t then
adamc@1112	2071 unurlify false env t
adamc@1112	2072 else
adamc@1112	2073 box [string "({",
adamc@1112	2074 newline,
adamc@1112	2075 p_typ env t,
adamc@1112	2076 string " *tmp = uw_malloc(ctx, sizeof(",
adamc@1112	2077 p_typ env t,
adamc@1112	2078 string "));",
adamc@1112	2079 newline,
adamc@1112	2080 string "*tmp = ",
adamc@1112	2081 unurlify false env t,
adamc@1112	2082 string ";",
adamc@1112	2083 newline,
adamc@1112	2084 string "tmp;",
adamc@1112	2085 newline,
adamc@1112	2086 string "})"]
adamc@1112	2087 in
adamc@1112	2088 box [string "({",
adamc@1112	2089 newline,
adamc@1112	2090 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
adam@1524	2091 p_exp' false false env e,
adamc@1112	2092 string ");",
adamc@1112	2093 newline,
adamc@1112	2094 newline,
adamc@1112	2095 unurlify false env t,
adamc@1112	2096 string ";",
adamc@1112	2097 newline,
adamc@1112	2098 string "})"]
adamc@1112	2099 end
adamc@1112	2100
adam@1524	2101 and p_exp env = p_exp' false true env
adamc@29	2102
adamc@1114	2103 fun p_fun isRec env (fx, n, args, ran, e) =
adamc@129	2104 let
adamc@129	2105 val nargs = length args
adamc@129	2106 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129	2107 in
adamc@129	2108 box [string "static",
adamc@129	2109 space,
adamc@129	2110 p_typ env ran,
adamc@129	2111 space,
adamc@316	2112 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
adamc@129	2113 string "(",
adamc@129	2114 p_list_sep (box [string ",", space]) (fn x => x)
adamc@311	2115 (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129	2116 box [p_typ env dom,
adamc@129	2117 space,
adamc@129	2118 p_rel env' (nargs - i - 1)]) args),
adamc@129	2119 string ")",
adamc@129	2120 space,
adamc@129	2121 string "{",
adam@1524	2122 if isRec then
adam@1524	2123 box [string "restart:",
adam@1524	2124 newline]
adam@1524	2125 else
adam@1524	2126 box [],
adamc@129	2127 newline,
adamc@1114	2128 if isRec andalso Settings.getDeadlines () then
adamc@1114	2129 box [string "uw_check_deadline(ctx);",
adamc@1114	2130 newline]
adamc@1114	2131 else
adamc@1114	2132 box [],
adamc@638	2133 box [string "return(",
adamc@638	2134 p_exp env' e,
adamc@638	2135 string ");"],
adamc@129	2136 newline,
adamc@129	2137 string "}"]
adamc@129	2138 end
adamc@129	2139
adamc@129	2140 fun p_decl env (dAll as (d, _) : decl) =
adamc@29	2141 case d of
adamc@29	2142 DStruct (n, xts) =>
adamc@196	2143 let
adamc@196	2144 val env = E.declBinds env dAll
adamc@196	2145 in
adamc@196	2146 box [string "struct",
adamc@196	2147 space,
adamc@311	2148 string ("__uws_" ^ Int.toString n),
adamc@196	2149 space,
adamc@196	2150 string "{",
adamc@196	2151 newline,
adamc@196	2152 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@196	2153 space,
adamc@311	2154 string "__uwf_",
adamc@316	2155 p_ident x,
adamc@196	2156 string ";",
adamc@196	2157 newline]) xts,
adamc@196	2158 string "};"]
adamc@196	2159 end
adamc@809	2160 \| DDatatype dts =>
adamc@165	2161 let
adamc@809	2162 val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) =>
adamc@809	2163 dk1 = Enum andalso dk2 <> Enum) dts
adamc@809	2164
adamc@809	2165 fun p_one (Enum, x, n, xncs) =
adamc@809	2166 box [string "enum",
adamc@809	2167 space,
adamc@809	2168 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809	2169 space,
adamc@809	2170 string "{",
adamc@809	2171 space,
adam@1298	2172 case xncs of
adam@1298	2173 [] => string ("__uwec_" ^ ident x ^ "_" ^ Int.toString n)
adam@1298	2174 \| _ =>
adam@1298	2175 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adam@1298	2176 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
adamc@809	2177 space,
adamc@809	2178 string "};"]
adamc@809	2179 \| p_one (Option, _, _, _) = box []
adamc@809	2180 \| p_one (Default, x, n, xncs) =
adamc@809	2181 let
adamc@809	2182 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@809	2183 \| (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@809	2184 in
adamc@809	2185 box [string "enum",
adamc@809	2186 space,
adamc@809	2187 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809	2188 space,
adamc@809	2189 string "{",
adamc@809	2190 space,
adamc@809	2191 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adamc@809	2192 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n))
adamc@809	2193 xncs,
adamc@809	2194 space,
adamc@809	2195 string "};",
adamc@809	2196 newline,
adamc@809	2197 newline,
adamc@809	2198 string "struct",
adamc@809	2199 space,
adamc@809	2200 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809	2201 space,
adamc@809	2202 string "{",
adamc@809	2203 newline,
adamc@809	2204 string "enum",
adamc@809	2205 space,
adamc@809	2206 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809	2207 space,
adamc@809	2208 string "tag;",
adamc@809	2209 newline,
adamc@809	2210 box (case xncsArgs of
adamc@809	2211 [] => []
adamc@809	2212 \| _ => [string "union",
adamc@809	2213 space,
adamc@809	2214 string "{",
adamc@809	2215 newline,
adamc@809	2216 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@809	2217 space,
adamc@809	2218 string ("uw_" ^ ident x),
adamc@809	2219 string ";"]) xncsArgs,
adamc@809	2220 newline,
adamc@809	2221 string "}",
adamc@809	2222 space,
adamc@809	2223 string "data;",
adamc@809	2224 newline]),
adamc@809	2225 string "};"]
adamc@809	2226 end
adamc@165	2227 in
adamc@809	2228 p_list_sep (box []) p_one dts
adamc@188	2229 end
adamc@29	2230
adamc@196	2231 \| DDatatypeForward _ => box []
adamc@196	2232
adamc@29	2233 \| DVal (x, n, t, e) =>
adamc@29	2234 box [p_typ env t,
adamc@29	2235 space,
adamc@316	2236 string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n),
adamc@29	2237 space,
adamc@29	2238 string "=",
adamc@29	2239 space,
adamc@29	2240 p_exp env e,
adamc@29	2241 string ";"]
adamc@1114	2242 \| DFun vi => p_fun false env vi
adamc@129	2243 \| DFunRec vis =>
adamc@29	2244 let
adamc@129	2245 val env = E.declBinds env dAll
adamc@29	2246 in
adamc@129	2247 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129	2248 box [string "static",
adamc@129	2249 space,
adamc@129	2250 p_typ env ran,
adamc@129	2251 space,
adamc@316	2252 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
adamc@311	2253 string "(uw_context,",
adamc@129	2254 space,
adamc@129	2255 p_list_sep (box [string ",", space])
adamc@129	2256 (fn (_, dom) => p_typ env dom) args,
adamc@129	2257 string ");"]) vis,
adamc@29	2258 newline,
adam@1524	2259 p_list_sep newline (fn vi as (_, n, _, _, _) =>
adam@1524	2260 (self := SOME n;
adam@1524	2261 p_fun true env vi
adam@1524	2262 before self := NONE)) vis,
adamc@129	2263 newline]
adamc@29	2264 end
adamc@707	2265 \| DTable (x, _, pk, csts) => box [string "/* SQL table ",
adamc@707	2266 string x,
adamc@707	2267 space,
adamc@707	2268 case pk of
adamc@707	2269 "" => box []
adamc@707	2270 \| _ => box [string "keys",
adamc@707	2271 space,
adamc@707	2272 string pk,
adamc@707	2273 space],
adamc@707	2274 string "constraints",
adamc@707	2275 space,
adamc@707	2276 p_list (fn (x, v) => box [string x,
adamc@707	2277 space,
adamc@707	2278 string ":",
adamc@707	2279 space,
adamc@707	2280 string v]) csts,
adamc@707	2281 space,
adamc@707	2282 string " */",
adamc@707	2283 newline]
adamc@338	2284 \| DSequence x => box [string "/* SQL sequence ",
adamc@338	2285 string x,
adamc@338	2286 string " */",
adamc@338	2287 newline]
adamc@754	2288 \| DView (x, _, s) => box [string "/* SQL view ",
adamc@754	2289 string x,
adamc@754	2290 space,
adamc@754	2291 string "AS",
adamc@754	2292 space,
adamc@754	2293 string s,
adamc@754	2294 space,
adamc@754	2295 string " */",
adamc@754	2296 newline]
adamc@870	2297 \| DDatabase _ => box []
adamc@870	2298 \| DPreparedStatements _ => box []
adamc@282	2299
adamc@569	2300 \| DJavaScript s => box [string "static char jslib[] = \"",
adam@1285	2301 string (String.toCString s),
adamc@569	2302 string "\";"]
adamc@725	2303 \| DCookie s => box [string "/*",
adamc@725	2304 space,
adamc@725	2305 string "cookie",
adamc@725	2306 space,
adamc@725	2307 string s,
adamc@725	2308 space,
adamc@725	2309 string "*/"]
adamc@720	2310 \| DStyle s => box [string "/*",
adamc@720	2311 space,
adamc@720	2312 string "style",
adamc@720	2313 space,
adamc@720	2314 string s,
adamc@720	2315 space,
adamc@720	2316 string "*/"]
adamc@569	2317
adamc@1075	2318 \| DTask _ => box []
adam@1294	2319 \| DOnError _ => box []
adamc@1073	2320
adamc@144	2321 datatype 'a search =
adamc@144	2322 Found of 'a
adamc@144	2323 \| NotFound
adamc@144	2324 \| Error
adamc@120	2325
adamc@467	2326 fun p_sqltype'' env (tAll as (t, loc)) =
adamc@275	2327 case t of
adamc@275	2328 TFfi ("Basis", "int") => "int8"
adamc@275	2329 \| TFfi ("Basis", "float") => "float8"
adamc@275	2330 \| TFfi ("Basis", "string") => "text"
adamc@275	2331 \| TFfi ("Basis", "bool") => "bool"
adamc@438	2332 \| TFfi ("Basis", "time") => "timestamp"
adamc@737	2333 \| TFfi ("Basis", "blob") => "bytea"
adamc@682	2334 \| TFfi ("Basis", "channel") => "int8"
adamc@682	2335 \| TFfi ("Basis", "client") => "int4"
adamc@275	2336 \| _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
adamc@275	2337 Print.eprefaces' [("Type", p_typ env tAll)];
adamc@275	2338 "ERROR")
adamc@275	2339
adamc@467	2340 fun p_sqltype' env (tAll as (t, loc)) =
adamc@467	2341 case t of
adamc@467	2342 (TOption t, _) => p_sqltype'' env t
adamc@467	2343 \| _ => p_sqltype'' env t ^ " NOT NULL"
adamc@467	2344
adamc@275	2345 fun p_sqltype env t = string (p_sqltype' env t)
adamc@101	2346
adamc@467	2347 fun p_sqltype_base' env t =
adamc@467	2348 case t of
adamc@467	2349 (TOption t, _) => p_sqltype'' env t
adamc@467	2350 \| _ => p_sqltype'' env t
adamc@467	2351
adamc@467	2352 fun p_sqltype_base env t = string (p_sqltype_base' env t)
adamc@467	2353
adamc@467	2354 fun is_not_null t =
adamc@467	2355 case t of
adamc@467	2356 (TOption _, _) => false
adamc@467	2357 \| _ => true
adamc@467	2358
adamc@734	2359 fun sigName fields =
adamc@734	2360 let
adamc@734	2361 fun inFields s = List.exists (fn (s', _) => s' = s) fields
adamc@734	2362
adamc@734	2363 fun getSigName n =
adamc@734	2364 let
adamc@734	2365 val s = "Sig" ^ Int.toString n
adamc@734	2366 in
adamc@734	2367 if inFields s then
adamc@734	2368 getSigName (n + 1)
adamc@734	2369 else
adamc@734	2370 s
adamc@734	2371 end
adamc@734	2372 in
adamc@734	2373 if inFields "Sig" then
adamc@734	2374 getSigName 0
adamc@734	2375 else
adamc@734	2376 "Sig"
adamc@734	2377 end
adamc@734	2378
adamc@101	2379 fun p_file env (ds, ps) =
adamc@29	2380 let
adam@1516	2381 val () = (clearUrlHandlers ();
adam@1516	2382 unurlifies := IS.empty;
adam@1516	2383 urlifies := IS.empty;
adam@1524	2384 urlifiesL := IS.empty;
adam@1524	2385 self := NONE)
adam@1516	2386
adamc@101	2387 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adam@1516	2388 let
adam@1516	2389 val d' = p_decl env d
adam@1546	2390 val hs = latestUrlHandlers ()
adam@1546	2391 val (protos, defs) = ListPair.unzip hs
adam@1516	2392 in
adam@1546	2393 (box (List.revAppend (protos, (List.revAppend (defs, [d'])))),
adam@1516	2394 E.declBinds env d)
adam@1516	2395 end)
adamc@101	2396 env ds
adamc@144	2397
adamc@779	2398 fun flatFields always (t : typ) =
adamc@756	2399 case #1 t of
adamc@756	2400 TRecord i =>
adamc@756	2401 let
adamc@756	2402 val xts = E.lookupStruct env i
adamc@756	2403 in
adamc@779	2404 SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts))
adamc@756	2405 end
adamc@759	2406 \| TList (_, i) =>
adamc@759	2407 let
adamc@759	2408 val ts = E.lookupStruct env i
adamc@759	2409 in
adamc@759	2410 case ts of
adamc@779	2411 [("1", t'), ("2", _)] => flatFields [] t'
adamc@759	2412 \| _ => raise Fail "CjrPrint: Bad struct for TList"
adamc@759	2413 end
adamc@756	2414 \| _ => NONE
adamc@756	2415
adamc@1104	2416 val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) =>
adamc@144	2417 case ek of
adam@1347	2418 Action eff =>
adam@1347	2419 (case List.nth (ts, length ts - 2) of
adam@1347	2420 (TRecord i, loc) =>
adam@1347	2421 let
adam@1347	2422 val xts = E.lookupStruct env i
adam@1347	2423 val extra = case eff of
adam@1347	2424 ReadCookieWrite => [sigName xts]
adam@1347	2425 \| _ => []
adam@1347	2426 in
adam@1347	2427 case flatFields extra (TRecord i, loc) of
adam@1347	2428 NONE => raise Fail "CjrPrint: flatFields impossible"
adam@1347	2429 \| SOME fields' => List.revAppend (fields', fields)
adam@1347	2430 end
adam@1347	2431 \| _ => raise Fail "CjrPrint: Last argument of action isn't record")
adam@1347	2432 \| _ => fields)
adamc@756	2433 [] ps
adamc@756	2434
adamc@756	2435 val fields = foldl (fn (xts, fields) =>
adamc@756	2436 let
adamc@756	2437 val xtsSet = SS.addList (SS.empty, xts)
adamc@756	2438 in
adamc@756	2439 foldl (fn (x, fields) =>
adamc@756	2440 let
adamc@756	2441 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@756	2442 in
adamc@756	2443 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@756	2444 xtsSet'))
adamc@756	2445 end) fields xts
adamc@756	2446 end)
adamc@756	2447 SM.empty fields
adamc@144	2448
adamc@144	2449 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144	2450 let
adamc@144	2451 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144	2452 case SM.find (fnums, x') of
adamc@144	2453 NONE => unusable
adamc@144	2454 \| SOME n => IS.add (unusable, n))
adamc@144	2455 IS.empty xs
adamc@144	2456
adamc@144	2457 fun findAvailable n =
adamc@144	2458 if IS.member (unusable, n) then
adamc@144	2459 findAvailable (n + 1)
adamc@144	2460 else
adamc@144	2461 n
adamc@144	2462 in
adamc@144	2463 SM.insert (fnums, x, findAvailable 0)
adamc@144	2464 end)
adamc@144	2465 SM.empty fields
adamc@144	2466
adamc@734	2467 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s \| _ => NONE) ds
adamc@734	2468
adamc@144	2469 fun makeSwitch (fnums, i) =
adamc@144	2470 case SM.foldl (fn (n, NotFound) => Found n
adamc@144	2471 \| (n, Error) => Error
adamc@144	2472 \| (n, Found n') => if n = n' then
adamc@144	2473 Found n'
adamc@144	2474 else
adamc@144	2475 Error) NotFound fnums of
adamc@144	2476 NotFound => box [string "return",
adamc@144	2477 space,
adamc@144	2478 string "-1;"]
adamc@144	2479 \| Found n => box [string "return",
adamc@144	2480 space,
adamc@144	2481 string (Int.toString n),
adamc@144	2482 string ";"]
adamc@144	2483 \| Error =>
adamc@144	2484 let
adamc@144	2485 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144	2486 let
adamc@144	2487 val ch = if i < size x then
adamc@144	2488 String.sub (x, i)
adamc@144	2489 else
adamc@144	2490 chr 0
adamc@144	2491
adamc@144	2492 val fnums = case CM.find (cmap, ch) of
adamc@144	2493 NONE => SM.empty
adamc@144	2494 \| SOME fnums => fnums
adamc@144	2495 val fnums = SM.insert (fnums, x, n)
adamc@144	2496 in
adamc@144	2497 CM.insert (cmap, ch, fnums)
adamc@144	2498 end)
adamc@144	2499 CM.empty fnums
adamc@144	2500
adamc@144	2501 val cmap = CM.listItemsi cmap
adamc@144	2502 in
adamc@144	2503 case cmap of
adamc@144	2504 [(_, fnums)] =>
adamc@144	2505 box [string "if",
adamc@144	2506 space,
adamc@144	2507 string "(name[",
adamc@144	2508 string (Int.toString i),
adamc@144	2509 string "]",
adamc@144	2510 space,
adamc@144	2511 string "==",
adamc@144	2512 space,
adamc@144	2513 string "0)",
adamc@144	2514 space,
adamc@144	2515 string "return",
adamc@144	2516 space,
adamc@144	2517 string "-1;",
adamc@144	2518 newline,
adamc@144	2519 makeSwitch (fnums, i+1)]
adamc@144	2520 \| _ =>
adamc@144	2521 box [string "switch",
adamc@144	2522 space,
adamc@144	2523 string "(name[",
adamc@144	2524 string (Int.toString i),
adamc@144	2525 string "])",
adamc@144	2526 space,
adamc@144	2527 string "{",
adamc@144	2528 newline,
adamc@144	2529 box (map (fn (ch, fnums) =>
adamc@144	2530 box [string "case",
adamc@144	2531 space,
adamc@144	2532 if ch = chr 0 then
adamc@144	2533 string "0:"
adamc@144	2534 else
adamc@144	2535 box [string "'",
adamc@144	2536 string (Char.toString ch),
adamc@144	2537 string "':"],
adamc@144	2538 newline,
adamc@144	2539 makeSwitch (fnums, i+1),
adamc@144	2540 newline]) cmap),
adamc@144	2541 string "default:",
adamc@144	2542 newline,
adamc@144	2543 string "return",
adamc@144	2544 space,
adamc@144	2545 string "-1;",
adamc@144	2546 newline,
adamc@144	2547 string "}"]
adamc@144	2548 end
adamc@144	2549
adamc@756	2550 fun getInput (x, t) =
adamc@756	2551 let
adamc@756	2552 val n = case SM.find (fnums, x) of
adamc@759	2553 NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums")
adamc@756	2554 \| SOME n => n
adamc@756	2555
adamc@756	2556 val f = case t of
adamc@756	2557 (TFfi ("Basis", "bool"), _) => "optional_"
adamc@756	2558 \| _ => ""
adamc@756	2559 in
adamc@756	2560 if isFile t then
adamc@756	2561 box [string "uw_input_",
adamc@756	2562 p_ident x,
adamc@756	2563 space,
adamc@756	2564 string "=",
adamc@756	2565 space,
adamc@756	2566 string "uw_get_file_input(ctx, ",
adamc@756	2567 string (Int.toString n),
adamc@756	2568 string ");",
adamc@756	2569 newline]
adamc@756	2570 else case #1 t of
adamc@756	2571 TRecord i =>
adamc@756	2572 let
adamc@756	2573 val xts = E.lookupStruct env i
adamc@756	2574 in
adamc@756	2575 box [string "uw_enter_subform(ctx, ",
adamc@756	2576 string (Int.toString n),
adamc@756	2577 string ");",
adamc@756	2578 newline,
adamc@756	2579 string "uw_input_",
adamc@756	2580 p_ident x,
adamc@756	2581 space,
adamc@756	2582 string "=",
adamc@756	2583 space,
adamc@756	2584 string "({",
adamc@756	2585 box [p_typ env t,
adamc@756	2586 space,
adamc@756	2587 string "result;",
adamc@756	2588 newline,
adamc@756	2589 p_list_sep (box [])
adamc@756	2590 (fn (x, t) =>
adamc@756	2591 box [p_typ env t,
adamc@756	2592 space,
adamc@756	2593 string "uw_input_",
adamc@756	2594 string x,
adamc@756	2595 string ";",
adamc@756	2596 newline])
adamc@756	2597 xts,
adamc@756	2598 newline,
adamc@756	2599 p_list_sep (box []) (fn (x, t) =>
adamc@756	2600 box [getInput (x, t),
adamc@756	2601 string "result.__uwf_",
adamc@756	2602 string x,
adamc@756	2603 space,
adamc@756	2604 string "=",
adamc@756	2605 space,
adamc@756	2606 string "uw_input_",
adamc@756	2607 string x,
adamc@756	2608 string ";",
adamc@756	2609 newline])
adamc@756	2610 xts,
adamc@756	2611 newline,
adamc@756	2612 string "result;",
adamc@756	2613 newline],
adamc@756	2614 string "});",
adamc@756	2615 newline,
adamc@756	2616 string "uw_leave_subform(ctx);"]
adamc@756	2617 end
adamc@759	2618 \| TList (t', i) =>
adamc@759	2619 let
adamc@759	2620 val xts = E.lookupStruct env i
adamc@759	2621 val i' = case xts of
adamc@759	2622 [("1", (TRecord i', loc)), ("2", _)] => i'
adamc@759	2623 \| _ => raise Fail "CjrPrint: Bad TList record [2]"
adamc@759	2624 val xts = E.lookupStruct env i'
adamc@759	2625 in
adamc@759	2626 box [string "{",
adamc@759	2627 newline,
adamc@759	2628 string "int status;",
adamc@759	2629 newline,
adamc@759	2630 string "uw_input_",
adamc@759	2631 p_ident x,
adamc@759	2632 space,
adamc@759	2633 string "=",
adamc@759	2634 space,
adamc@759	2635 string "NULL;",
adamc@759	2636 newline,
adamc@759	2637 string "for (status = uw_enter_subforms(ctx, ",
adamc@759	2638 string (Int.toString n),
adamc@759	2639 string "); status; status = uw_next_entry(ctx)) {",
adamc@759	2640 newline,
adamc@759	2641 box [p_typ env t,
adamc@759	2642 space,
adamc@759	2643 string "result",
adamc@759	2644 space,
adamc@759	2645 string "=",
adamc@759	2646 space,
adamc@759	2647 string "uw_malloc(ctx, sizeof(struct __uws_",
adamc@759	2648 string (Int.toString i),
adamc@759	2649 string "));",
adamc@759	2650 newline,
adamc@759	2651 box [string "{",
adamc@759	2652 p_list_sep (box [])
adamc@759	2653 (fn (x, t) =>
adamc@759	2654 box [p_typ env t,
adamc@759	2655 space,
adamc@759	2656 string "uw_input_",
adamc@759	2657 string x,
adamc@759	2658 string ";",
adamc@759	2659 newline])
adamc@759	2660 xts,
adamc@759	2661 newline,
adamc@759	2662 p_list_sep (box []) (fn (x, t) =>
adamc@759	2663 box [getInput (x, t),
adamc@759	2664 string "result->__uwf_1.__uwf_",
adamc@759	2665 string x,
adamc@759	2666 space,
adamc@759	2667 string "=",
adamc@759	2668 space,
adamc@759	2669 string "uw_input_",
adamc@759	2670 string x,
adamc@759	2671 string ";",
adamc@759	2672 newline])
adamc@759	2673 xts,
adamc@759	2674 string "}",
adamc@759	2675 newline],
adamc@759	2676 newline,
adamc@759	2677 string "result->__uwf_2 = uw_input_",
adamc@759	2678 p_ident x,
adamc@759	2679 string ";",
adamc@759	2680 newline,
adamc@759	2681 string "uw_input_",
adamc@759	2682 p_ident x,
adamc@759	2683 string " = result;",
adamc@759	2684 newline],
adamc@759	2685 string "}}",
adamc@759	2686 newline]
adamc@759	2687 end
adamc@756	2688 \| _ =>
adamc@756	2689 box [string "request = uw_get_",
adamc@756	2690 string f,
adamc@756	2691 string "input(ctx, ",
adamc@756	2692 string (Int.toString n),
adamc@756	2693 string ");",
adamc@756	2694 newline,
adamc@756	2695 string "if (request == NULL)",
adamc@756	2696 newline,
adamc@756	2697 box [string "uw_error(ctx, FATAL, \"Missing input ",
adamc@756	2698 string x,
adamc@756	2699 string "\");"],
adamc@756	2700 newline,
adamc@756	2701 string "uw_input_",
adamc@756	2702 p_ident x,
adamc@756	2703 space,
adamc@756	2704 string "=",
adamc@756	2705 space,
adamc@1023	2706 unurlify true env t,
adamc@756	2707 string ";",
adamc@756	2708 newline]
adamc@756	2709 end
adamc@756	2710
adam@1542	2711 val timestamp = LargeInt.toString (Time.toMilliseconds (Time.now ()))
adam@1542	2712 val app_js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
adam@1542	2713 file = "app." ^ timestamp ^ ".js"}
adam@1542	2714
adamc@1104	2715 fun p_page (ek, s, n, ts, ran, side, tellSig) =
adamc@144	2716 let
adamc@734	2717 val (ts, defInputs, inputsVar, fields) =
adamc@144	2718 case ek of
adam@1347	2719 Core.Action _ =>
adam@1347	2720 (case List.nth (ts, length ts - 2) of
adam@1347	2721 (TRecord i, _) =>
adam@1347	2722 let
adam@1347	2723 val xts = E.lookupStruct env i
adam@1347	2724 in
adam@1347	2725 (List.take (ts, length ts - 2),
adam@1347	2726 box [box (map (fn (x, t) => box [p_typ env t,
adam@1347	2727 space,
adam@1347	2728 string "uw_input_",
adam@1347	2729 p_ident x,
adam@1347	2730 string ";",
adam@1347	2731 newline]) xts),
adam@1347	2732 newline,
adam@1347	2733 box (map getInput xts),
adam@1431	2734 case i of
adam@1431	2735 0 => string "uw_unit uw_inputs;"
adam@1431	2736 \| _ => box [string "struct __uws_",
adam@1431	2737 string (Int.toString i),
adam@1431	2738 space,
adam@1431	2739 string "uw_inputs",
adam@1431	2740 space,
adam@1431	2741 string "= {",
adam@1431	2742 newline,
adam@1431	2743 box (map (fn (x, _) => box [string "uw_input_",
adam@1431	2744 p_ident x,
adam@1431	2745 string ",",
adam@1431	2746 newline]) xts),
adam@1431	2747 string "};"],
adam@1347	2748 newline],
adam@1347	2749 box [string ",",
adam@1347	2750 space,
adam@1347	2751 string "uw_inputs"],
adam@1347	2752 SOME xts)
adam@1347	2753 end
adamc@144	2754
adam@1347	2755 \| _ => raise Fail "CjrPrint: Last argument to an action isn't a record")
adam@1347	2756 \| _ => (List.take (ts, length ts - 1), string "", string "", NONE)
adamc@734	2757
adamc@734	2758 fun couldWrite ek =
adamc@734	2759 case ek of
adamc@734	2760 Link => false
adamc@735	2761 \| Action ef => ef = ReadCookieWrite
adamc@735	2762 \| Rpc ef => ef = ReadCookieWrite
adam@1384	2763 \| Extern _ => false
adamc@863	2764
adamc@863	2765 val s =
adamc@863	2766 case Settings.getUrlPrefix () of
adamc@863	2767 "" => s
adamc@863	2768 \| "/" => s
adamc@863	2769 \| prefix =>
adamc@863	2770 if size s > 0 andalso String.sub (s, 0) = #"/" then
adamc@863	2771 prefix ^ String.extract (s, 1, NONE)
adamc@863	2772 else
adamc@863	2773 prefix ^ s
adamc@144	2774 in
adamc@735	2775 box [string "if (!strncmp(request, \"",
adam@1285	2776 string (String.toCString s),
adamc@735	2777 string "\", ",
adamc@735	2778 string (Int.toString (size s)),
adamc@735	2779 string ") && (request[",
adamc@735	2780 string (Int.toString (size s)),
adamc@735	2781 string "] == 0 \|\| request[",
adamc@735	2782 string (Int.toString (size s)),
adamc@735	2783 string "] == '/')) {",
adamc@735	2784 newline,
adamc@735	2785 string "request += ",
adamc@735	2786 string (Int.toString (size s)),
adamc@735	2787 string ";",
adamc@735	2788 newline,
adamc@735	2789 string "if (*request == '/') ++request;",
adamc@735	2790 newline,
adam@1478	2791 if couldWrite ek andalso not (Settings.checkNoXsrfProtection s) then
adamc@734	2792 box [string "{",
adamc@734	2793 newline,
adamc@734	2794 string "uw_Basis_string sig = ",
adamc@734	2795 case fields of
adamc@734	2796 NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
adamc@734	2797 \| SOME fields =>
adamc@734	2798 case SM.find (fnums, sigName fields) of
adamc@734	2799 NONE => raise Fail "CjrPrint: sig name wasn't assigned a number"
adamc@734	2800 \| SOME inum =>
adamc@734	2801 string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"),
adamc@734	2802 string ";",
adamc@734	2803 newline,
adamc@734	2804 string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");",
adamc@734	2805 newline,
adam@1512	2806 string "if (!uw_streq(sig, uw_cookie_sig(ctx)))",
adamc@734	2807 newline,
adamc@734	2808 box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");",
adamc@734	2809 newline],
adamc@734	2810 string "}",
adamc@734	2811 newline]
adamc@734	2812 else
adamc@734	2813 box [],
adamc@609	2814 box (case ek of
adamc@731	2815 Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
adamc@731	2816 newline]
kkallio@1596	2817 \| _ => [string "uw_write_header(ctx, \"Content-type: text/html; charset=utf-8\\r\\n\");",
adamc@609	2818 newline,
adamc@609	2819 string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
adamc@609	2820 newline,
adamc@804	2821 string "uw_write(ctx, begin_xhtml);",
adamc@643	2822 newline,
adam@1451	2823 string "uw_mayReturnIndirectly(ctx);",
adam@1451	2824 newline,
adamc@643	2825 string "uw_set_script_header(ctx, \"",
adamc@812	2826 let
adamc@812	2827 val scripts =
adamc@812	2828 case side of
adamc@693	2829 ServerOnly => ""
adamc@1111	2830 \| _ =>
adamc@1111	2831 let
adamc@1111	2832 val scripts =
kkallio@1456	2833 "<script type=\\\"text/javascript\\\" src=\\\""
adam@1542	2834 ^ app_js
adamc@1111	2835 ^ "\\\"></script>\\n"
adamc@1111	2836 in
adamc@1111	2837 foldl (fn (x, scripts) =>
adamc@1111	2838 scripts
kkallio@1456	2839 ^ "<script type=\\\"text/javascript\\\" src=\\\"" ^ x ^ "\\\"></script>\\n")
adamc@1111	2840 scripts (Settings.getScripts ())
adamc@1111	2841 end
adamc@812	2842 in
adamc@812	2843 string scripts
adamc@812	2844 end,
adamc@643	2845 string "\");",
adamc@609	2846 newline]),
adamc@1038	2847 string "uw_set_needs_push(ctx, ",
adamc@1038	2848 string (case side of
adamc@1038	2849 ServerAndPullAndPush => "1"
adamc@1038	2850 \| _ => "0"),
adamc@1038	2851 string ");",
adamc@1038	2852 newline,
adamc@736	2853 string "uw_set_needs_sig(ctx, ",
adamc@1104	2854 string (if tellSig then
adamc@736	2855 "1"
adamc@736	2856 else
adamc@736	2857 "0"),
adamc@736	2858 string ");",
adamc@736	2859 newline,
adamc@682	2860 string "uw_login(ctx);",
adamc@682	2861 newline,
adamc@144	2862 box [string "{",
adamc@144	2863 newline,
adamc@144	2864 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144	2865 space,
adamc@144	2866 string "arg",
adamc@144	2867 string (Int.toString i),
adamc@144	2868 space,
adamc@144	2869 string "=",
adamc@144	2870 space,
adam@1347	2871 case #1 t of
adam@1347	2872 TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)"
adam@1370	2873 \| TOption (TFfi ("Basis", "queryString"), _) => string "uw_queryString(ctx)"
adam@1347	2874 \| _ => unurlify false env t,
adamc@144	2875 string ";",
adamc@144	2876 newline]) ts),
adamc@144	2877 defInputs,
adamc@609	2878 box (case ek of
adamc@731	2879 Core.Rpc _ => [p_typ env ran,
adamc@731	2880 space,
adamc@731	2881 string "it0",
adamc@731	2882 space,
adamc@731	2883 string "=",
adamc@731	2884 space]
adamc@609	2885 \| _ => []),
adamc@144	2886 p_enamed env n,
adamc@144	2887 string "(",
adamc@144	2888 p_list_sep (box [string ",", space])
adamc@144	2889 (fn x => x)
adamc@272	2890 (string "ctx"
adamc@280	2891 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144	2892 inputsVar,
adam@1431	2893 string ", 0);",
adamc@144	2894 newline,
adamc@609	2895 box (case ek of
adam@1446	2896 Core.Rpc _ => [string "uw_write(ctx, uw_get_real_script(ctx));",
adam@1446	2897 newline,
adam@1446	2898 string "uw_write(ctx, \"\\n\");",
adam@1446	2899 newline,
adam@1446	2900 urlify env ran]
adamc@609	2901 \| _ => [string "uw_write(ctx, \"</html>\");",
adamc@609	2902 newline]),
adamc@144	2903 string "return;",
adamc@144	2904 newline,
adamc@144	2905 string "}",
adamc@144	2906 newline,
adamc@144	2907 string "}"]
adamc@144	2908 ]
adamc@144	2909 end
adamc@144	2910
adam@1516	2911 val (pds', handlers) = ListUtil.foldlMap (fn (p, handlers) =>
adam@1516	2912 let
adam@1516	2913 val p' = p_page p
adam@1516	2914 in
adam@1516	2915 (p', latestUrlHandlers () @ handlers)
adam@1516	2916 end) [] ps
adam@1546	2917 val (protos, defs) = ListPair.unzip handlers
adam@1546	2918
adamc@870	2919 val hasDb = ref false
adamc@870	2920 val tables = ref []
adamc@872	2921 val views = ref []
adamc@870	2922 val sequences = ref []
adamc@870	2923 val dbstring = ref ""
adamc@870	2924 val expunge = ref 0
adamc@870	2925 val initialize = ref 0
adamc@870	2926 val prepped = ref []
adamc@275	2927
adamc@870	2928 val () = app (fn d =>
adamc@870	2929 case #1 d of
adamc@870	2930 DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
adamc@870	2931 dbstring := x;
adamc@870	2932 expunge := y;
adamc@870	2933 initialize := z)
adamc@870	2934 \| DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
adamc@870	2935 (x, sql_type_in env t)) xts) :: !tables
adamc@872	2936 \| DView (s, xts, _) => views := (s, map (fn (x, t) =>
adamc@872	2937 (x, sql_type_in env t)) xts) :: !views
adamc@870	2938 \| DSequence s => sequences := s :: !sequences
adamc@870	2939 \| DPreparedStatements ss => prepped := ss
adamc@870	2940 \| _ => ()) ds
adamc@377	2941
adam@1381	2942 val hasDb = !hasDb
adam@1381	2943
adam@1381	2944 fun expDb (e, _) =
adam@1381	2945 case e of
adam@1381	2946 ECon (_, _, SOME e) => expDb e
adam@1381	2947 \| ESome (_, e) => expDb e
adam@1381	2948 \| EFfiApp (_, _, es) => List.exists expDb es
adam@1381	2949 \| EApp (e, es) => expDb e orelse List.exists expDb es
adam@1381	2950 \| EUnop (_, e) => expDb e
adam@1381	2951 \| EBinop (_, e1, e2) => expDb e1 orelse expDb e2
adam@1381	2952 \| ERecord (_, xes) => List.exists (expDb o #2) xes
adam@1381	2953 \| EField (e, _) => expDb e
adam@1381	2954 \| ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
adam@1381	2955 \| EError (e, _) => expDb e
adam@1381	2956 \| EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
adam@1381	2957 \| ERedirect (e, _) => expDb e
adam@1381	2958 \| EWrite e => expDb e
adam@1381	2959 \| ESeq (e1, e2) => expDb e1 orelse expDb e2
adam@1381	2960 \| ELet (_, _, e1, e2) => expDb e1 orelse expDb e2
adam@1381	2961 \| EQuery _ => true
adam@1381	2962 \| EDml _ => true
adam@1381	2963 \| ENextval _ => true
adam@1381	2964 \| ESetval _ => true
adam@1381	2965 \| EUnurlify (e, _, _) => expDb e
adam@1381	2966 \| _ => false
adam@1381	2967
adam@1381	2968 fun declDb (d, _) =
adam@1381	2969 case d of
adam@1381	2970 DVal (_, _, _, e) => expDb e
adam@1381	2971 \| DFun (_, _, _, _, e) => expDb e
adam@1381	2972 \| DFunRec vis => List.exists (expDb o #5) vis
adam@1381	2973 \| _ => false
adam@1381	2974
adam@1381	2975 val () = if not hasDb andalso List.exists declDb ds then
adam@1381	2976 ErrorMsg.error "Application uses a database but has none configured with 'database' in .urp file."
adam@1381	2977 else
adam@1381	2978 ()
adamc@734	2979
adamc@734	2980 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s \| _ => NONE) ds
adamc@734	2981
adamc@734	2982 val cookieCode = foldl (fn (cookie, acc) =>
adamc@734	2983 SOME (case acc of
adamc@734	2984 NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734	2985 ^ cookie ^ "\"))")
adamc@734	2986 \| SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734	2987 ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
adamc@734	2988 acc,
adamc@734	2989 string "))"]))
adamc@734	2990 NONE cookies
adamc@770	2991
adamc@770	2992 fun makeChecker (name, rules : Settings.rule list) =
adamc@1094	2993 box [string "static int ",
adamc@770	2994 string name,
adamc@770	2995 string "(const char *s) {",
adamc@770	2996 newline,
adamc@770	2997 box [p_list_sep (box [])
adamc@770	2998 (fn rule =>
adamc@770	2999 box [string "if (!str",
adamc@770	3000 case #kind rule of
adamc@770	3001 Settings.Exact => box [string "cmp(s, \"",
adam@1285	3002 string (String.toCString (#pattern rule)),
adamc@770	3003 string "\"))"]
adamc@770	3004 \| Settings.Prefix => box [string "ncmp(s, \"",
adam@1285	3005 string (String.toCString (#pattern rule)),
adamc@770	3006 string "\", ",
adamc@770	3007 string (Int.toString (size (#pattern rule))),
adamc@770	3008 string "))"],
adamc@770	3009 string " return ",
adamc@770	3010 string (case #action rule of
adamc@770	3011 Settings.Allow => "1"
adamc@770	3012 \| Settings.Deny => "0"),
adamc@770	3013 string ";",
adamc@770	3014 newline]) rules,
adamc@770	3015 string "return 0;",
adamc@770	3016 newline],
adamc@770	3017 string "}",
adamc@770	3018 newline]
adamc@1073	3019
adam@1348	3020 val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) \| _ => NONE) ds
adam@1348	3021 val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) \| _ => NONE) ds
adam@1349	3022 val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) \| _ => NONE) ds
adamc@1263	3023
adam@1294	3024 val onError = ListUtil.search (fn (DOnError n, _) => SOME n \| _ => NONE) ds
adam@1294	3025
adamc@1263	3026 val now = Time.now ()
adamc@1263	3027 val nowD = Date.fromTimeUniv now
adamc@1263	3028 val rfcFmt = "%a, %d %b %Y %H:%M:%S"
adamc@29	3029 in
adamc@1263	3030 box [string "#include \"",
adamc@1263	3031 string (OS.Path.joinDirFile {dir = Config.includ,
adamc@1263	3032 file = "config.h"}),
adamc@1263	3033 string "\"",
adamc@1263	3034 newline,
adamc@1263	3035 string "#include <stdio.h>",
adamc@144	3036 newline,
adamc@144	3037 string "#include <stdlib.h>",
adamc@144	3038 newline,
adamc@272	3039 string "#include <string.h>",
adamc@272	3040 newline,
adamc@390	3041 string "#include <math.h>",
adamc@390	3042 newline,
adamc@1263	3043 string "#include <time.h>",
adamc@1263	3044 newline,
adamc@432	3045 if hasDb then
adamc@866	3046 box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
adamc@432	3047 newline]
adamc@432	3048 else
adamc@432	3049 box [],
adamc@764	3050 p_list_sep (box []) (fn s => box [string "#include \"",
adamc@764	3051 string s,
adamc@764	3052 string "\"",
adamc@764	3053 newline]) (Settings.getHeaders ()),
adamc@378	3054 string "#include \"",
adamc@378	3055 string (OS.Path.joinDirFile {dir = Config.includ,
adamc@378	3056 file = "urweb.h"}),
adamc@378	3057 string "\"",
adamc@101	3058 newline,
adamc@101	3059 newline,
adamc@804	3060
adam@1307	3061 box [string "static void uw_setup_limits() {",
adam@1307	3062 newline,
adam@1332	3063 case Settings.getMinHeap () of
adam@1332	3064 0 => box []
adam@1332	3065 \| n => box [string "uw_min_heap",
adam@1332	3066 space,
adam@1332	3067 string "=",
adam@1332	3068 space,
adam@1332	3069 string (Int.toString n),
adam@1332	3070 string ";",
adam@1332	3071 newline,
adam@1332	3072 newline],
adam@1307	3073 box [p_list_sep (box []) (fn (class, num) =>
adam@1307	3074 let
adam@1307	3075 val num = case class of
adam@1307	3076 "page" => Int.max (2048, num)
adam@1307	3077 \| _ => num
adam@1307	3078 in
adam@1307	3079 box [string ("uw_" ^ class ^ "_max"),
adam@1307	3080 space,
adam@1307	3081 string "=",
adam@1307	3082 space,
adam@1307	3083 string (Int.toString num),
adam@1307	3084 string ";",
adam@1307	3085 newline]
adam@1307	3086 end) (Settings.limits ())],
adam@1307	3087 string "}",
adam@1307	3088 newline,
adam@1307	3089 newline],
adam@1307	3090
adamc@1164	3091 #code (Settings.currentProtocol ()) (),
adamc@1164	3092
adamc@870	3093 if hasDb then
adamc@870	3094 #init (Settings.currentDbms ()) {dbstring = !dbstring,
adamc@870	3095 prepared = !prepped,
adamc@870	3096 tables = !tables,
adamc@872	3097 views = !views,
adamc@870	3098 sequences = !sequences}
adamc@870	3099 else
adam@1307	3100 box [string "static void uw_client_init(void) { };",
adamc@891	3101 newline,
adam@1307	3102 string "static void uw_db_init(uw_context ctx) { };",
adamc@870	3103 newline,
adam@1307	3104 string "static int uw_db_begin(uw_context ctx) { return 0; };",
adamc@870	3105 newline,
adam@1307	3106 string "static void uw_db_close(uw_context ctx) { };",
adamc@1094	3107 newline,
adam@1307	3108 string "static int uw_db_commit(uw_context ctx) { return 0; };",
adamc@870	3109 newline,
adam@1307	3110 string "static int uw_db_rollback(uw_context ctx) { return 0; };"],
adamc@870	3111 newline,
adamc@870	3112 newline,
adamc@870	3113
adam@1407	3114 string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
adam@1407	3115 newline,
adam@1407	3116 newline,
adam@1407	3117
adam@1407	3118 p_list_sep newline (fn x => x) pds,
adam@1407	3119 newline,
adam@1407	3120 newline,
adam@1407	3121 string "static int uw_input_num(const char *name) {",
adam@1407	3122 newline,
adam@1407	3123 makeSwitch (fnums, 0),
adam@1407	3124 string "}",
adam@1407	3125 newline,
adam@1407	3126 newline,
adam@1407	3127
adam@1349	3128 box (ListUtil.mapi (fn (i, (_, x1, x2, e)) =>
adam@1349	3129 box [string "static void uw_periodic",
adam@1349	3130 string (Int.toString i),
adam@1349	3131 string "(uw_context ctx) {",
adam@1349	3132 newline,
adam@1349	3133 box [string "uw_unit __uwr_",
adam@1349	3134 string x1,
adam@1431	3135 string "_0 = 0, __uwr_",
adam@1349	3136 string x2,
adam@1431	3137 string "_1 = 0;",
adam@1349	3138 newline,
adam@1349	3139 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
adam@1349	3140 string ";",
adam@1349	3141 newline],
adam@1349	3142 string "}",
adam@1349	3143 newline,
adam@1349	3144 newline]) periodics),
adam@1349	3145
adam@1349	3146 string "static uw_periodic my_periodics[] = {",
adam@1349	3147 box (ListUtil.mapi (fn (i, (n, _, _, _)) =>
adam@1349	3148 box [string "{uw_periodic",
adam@1349	3149 string (Int.toString i),
adam@1349	3150 string ",",
adam@1349	3151 space,
adam@1349	3152 string (Int64.toString n),
adam@1349	3153 string "},"]) periodics),
adam@1349	3154 string "{NULL}};",
adam@1349	3155 newline,
adam@1349	3156 newline,
adam@1349	3157
adamc@770	3158 makeChecker ("uw_check_url", Settings.getUrlRules ()),
adamc@770	3159 newline,
adamc@770	3160
adamc@770	3161 makeChecker ("uw_check_mime", Settings.getMimeRules ()),
adamc@770	3162 newline,
adam@1465	3163
adam@1465	3164 makeChecker ("uw_check_requestHeader", Settings.getRequestHeaderRules ()),
adam@1465	3165 newline,
adam@1465	3166
adam@1465	3167 makeChecker ("uw_check_responseHeader", Settings.getResponseHeaderRules ()),
adam@1465	3168 newline,
adamc@734	3169
adamc@734	3170 string "extern void uw_sign(const char in, char out);",
adamc@734	3171 newline,
adamc@734	3172 string "extern int uw_hash_blocksize;",
adamc@734	3173 newline,
adamc@1094	3174 string "static uw_Basis_string uw_cookie_sig(uw_context ctx) {",
adamc@734	3175 newline,
adamc@734	3176 box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);",
adamc@734	3177 newline,
adamc@734	3178 string "uw_sign(",
adamc@734	3179 case cookieCode of
adamc@734	3180 NONE => string "\"\""
adamc@734	3181 \| SOME code => code,
adamc@734	3182 string ", r);",
adamc@734	3183 newline,
adamc@734	3184 string "return uw_Basis_makeSigString(ctx, r);",
adamc@734	3185 newline],
adamc@734	3186 string "}",
adamc@734	3187 newline,
adamc@734	3188 newline,
adamc@734	3189
adam@1546	3190 box (rev protos),
adam@1546	3191 box (rev defs),
adam@1516	3192
adamc@1094	3193 string "static void uw_handle(uw_context ctx, char *request) {",
adamc@101	3194 newline,
adamc@863	3195 string "if (!strcmp(request, \"",
adam@1542	3196 string app_js,
adamc@863	3197 string "\")) {",
adamc@569	3198 newline,
adamc@1263	3199 box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");",
adamc@1263	3200 newline,
adamc@1263	3201 string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"),
adamc@1263	3202 newline,
adamc@1263	3203 box [string "uw_clear_headers(ctx);",
adamc@1263	3204 newline,
adam@1320	3205 string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");",
adamc@1263	3206 newline,
adamc@1263	3207 string "return;",
adamc@1263	3208 newline],
adamc@1263	3209 string "}",
adamc@1263	3210 newline,
adamc@1263	3211 newline,
adamc@1263	3212 string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");",
adamc@1263	3213 newline,
adamc@1263	3214 string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
adamc@569	3215 newline,
adamc@569	3216 string "uw_write(ctx, jslib);",
adamc@569	3217 newline,
adamc@569	3218 string "return;",
adamc@569	3219 newline],
adamc@569	3220 string "}",
adamc@569	3221 newline,
adamc@101	3222 p_list_sep newline (fn x => x) pds',
adamc@101	3223 newline,
adamc@1110	3224 string "uw_clear_headers(ctx);",
adamc@1110	3225 newline,
adamc@1110	3226 string "uw_write_header(ctx, \"HTTP/1.1 404 Not Found\\r\\nContent-type: text/plain\\r\\n\");",
adamc@1110	3227 newline,
adamc@1110	3228 string "uw_write(ctx, \"Not Found\");",
adamc@387	3229 newline,
adamc@101	3230 string "}",
adamc@275	3231 newline,
adamc@275	3232 newline,
adamc@870	3233
adam@1348	3234 box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
adam@1348	3235 newline,
adam@1348	3236
adam@1348	3237 p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
adam@1348	3238 newline,
adam@1348	3239 string "uw_Basis_client __uwr_",
adam@1348	3240 string x1,
adam@1348	3241 string "_0 = cli;",
adam@1348	3242 newline,
adam@1348	3243 string "uw_unit __uwr_",
adam@1348	3244 string x2,
adam@1431	3245 string "_1 = 0;",
adam@1348	3246 newline,
adam@1348	3247 p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
adam@1348	3248 x2 dummyt) e,
adam@1348	3249 string ";",
adam@1348	3250 newline,
adam@1348	3251 string "});",
adam@1348	3252 newline]) expungers,
adam@1348	3253
adam@1348	3254 if hasDb then
adamc@870	3255 box [p_enamed env (!expunge),
adamc@870	3256 string "(ctx, cli);",
adam@1348	3257 newline]
adam@1348	3258 else
adam@1348	3259 box [],
adam@1348	3260 string "}"],
adamc@870	3261
adam@1348	3262 newline,
adam@1348	3263 string "static void uw_initializer(uw_context ctx) {",
adam@1348	3264 newline,
adam@1348	3265 box [p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
adam@1348	3266 newline,
adam@1348	3267 string "uw_unit __uwr_",
adam@1348	3268 string x1,
adam@1431	3269 string "_0 = 0, __uwr_",
adam@1348	3270 string x2,
adam@1431	3271 string "_1 = 0;",
adam@1348	3272 newline,
adam@1348	3273 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
adam@1348	3274 string ";",
adam@1348	3275 newline,
adam@1348	3276 string "});",
adam@1348	3277 newline]) initializers,
adam@1348	3278 if hasDb then
adam@1348	3279 box [p_enamed env (!initialize),
adam@1431	3280 string "(ctx, 0);",
adam@1348	3281 newline]
adam@1348	3282 else
adam@1348	3283 box []],
adam@1348	3284 string "}",
adam@1348	3285 newline,
adamc@1094	3286
adam@1294	3287 case onError of
adam@1294	3288 NONE => box []
adam@1294	3289 \| SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {",
adam@1294	3290 newline,
adam@1483	3291 if Settings.getDebug () then
adam@1483	3292 box []
adam@1483	3293 else
adam@1483	3294 box [string "uw_cutErrorLocation(msg);",
adam@1483	3295 newline],
adam@1294	3296 box [string "uw_write(ctx, ",
adam@1294	3297 p_enamed env n,
adam@1431	3298 string "(ctx, msg, 0));",
adam@1294	3299 newline],
adam@1294	3300 string "}",
adam@1294	3301 newline,
adam@1294	3302 newline],
adam@1294	3303
adamc@1094	3304 string "uw_app uw_application = {",
adamc@1094	3305 p_list_sep (box [string ",", newline]) string
adamc@1094	3306 [Int.toString (SM.foldl Int.max 0 fnums + 1),
adamc@1094	3307 Int.toString (Settings.getTimeout ()),
adamc@1094	3308 "\"" ^ Settings.getUrlPrefix () ^ "\"",
adamc@1094	3309 "uw_client_init", "uw_initializer", "uw_expunger",
adamc@1094	3310 "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
adamc@1094	3311 "uw_handle",
adam@1465	3312 "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader",
adam@1349	3313 case onError of NONE => "NULL" \| SOME _ => "uw_onError", "my_periodics"],
adamc@1094	3314 string "};",
adamc@1094	3315 newline]
adamc@29	3316 end
adamc@29	3317
adamc@274	3318 fun p_sql env (ds, _) =
adamc@274	3319 let
adamc@274	3320 val (pps, _) = ListUtil.foldlMap
adamc@274	3321 (fn (dAll as (d, _), env) =>
adamc@274	3322 let
adamc@274	3323 val pp = case d of
adamc@707	3324 DTable (s, xts, pk, csts) =>
adamc@274	3325 box [string "CREATE TABLE ",
adamc@274	3326 string s,
adamc@274	3327 string "(",
adamc@274	3328 p_list (fn (x, t) =>
adamc@874	3329 let
adamc@874	3330 val t = sql_type_in env t
adamc@874	3331 in
adamc@874	3332 box [string "uw_",
adamc@874	3333 string (CharVector.map Char.toLower x),
adamc@874	3334 space,
adamc@874	3335 string (#p_sql_type (Settings.currentDbms ()) t),
adamc@874	3336 case t of
adamc@874	3337 Nullable _ => box []
adamc@874	3338 \| _ => string " NOT NULL"]
adamc@874	3339 end) xts,
adamc@707	3340 case (pk, csts) of
adamc@707	3341 ("", []) => box []
adamc@707	3342 \| _ => string ",",
adamc@704	3343 cut,
adamc@707	3344 case pk of
adamc@707	3345 "" => box []
adamc@707	3346 \| _ => box [string "PRIMARY",
adamc@707	3347 space,
adamc@707	3348 string "KEY",
adamc@707	3349 space,
adamc@707	3350 string "(",
adamc@707	3351 string pk,
adamc@707	3352 string ")",
adamc@707	3353 case csts of
adamc@707	3354 [] => box []
adamc@707	3355 \| _ => string ",",
adamc@707	3356 newline],
adamc@704	3357 p_list_sep (box [string ",", newline])
adamc@704	3358 (fn (x, c) =>
adamc@704	3359 box [string "CONSTRAINT",
adamc@704	3360 space,
adamc@704	3361 string s,
adamc@704	3362 string "_",
adamc@704	3363 string x,
adamc@704	3364 space,
adamc@704	3365 string c]) csts,
adamc@704	3366 newline,
adamc@274	3367 string ");",
adamc@274	3368 newline,
adamc@274	3369 newline]
adamc@338	3370 \| DSequence s =>
adamc@877	3371 box [string (#createSequence (Settings.currentDbms ()) s),
adamc@338	3372 string ";",
adamc@338	3373 newline,
adamc@338	3374 newline]
adamc@754	3375 \| DView (s, xts, q) =>
adamc@754	3376 box [string "CREATE VIEW",
adamc@754	3377 space,
adamc@754	3378 string s,
adamc@754	3379 space,
adamc@754	3380 string "AS",
adamc@754	3381 space,
adamc@754	3382 string q,
adamc@754	3383 string ";",
adamc@754	3384 newline,
adamc@754	3385 newline]
adamc@274	3386 \| _ => box []
adamc@274	3387 in
adamc@274	3388 (pp, E.declBinds env dAll)
adamc@274	3389 end)
adamc@274	3390 env ds
adamc@274	3391 in
adamc@882	3392 box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
adamc@274	3393 end
adamc@274	3394
adamc@29	3395 end

Mercurial > urweb

annotate src/cjr_print.sml @ 1609:c6cc104a47ac