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