Ur/Web: src/cjr_print.sml annotate

annotate src/cjr_print.sml @ 1537:e627bab3eda7

Fix list urlification

author	Adam Chlipala <adam@chlipala.net>
date	Sun, 14 Aug 2011 16:46:36 -0400
parents	a71223513c77
children	dc4c61363d0a

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

Mercurial > urweb

annotate src/cjr_print.sml @ 1537:e627bab3eda7