Mercurial > urweb

annotate src/cjr_print.sml @ 853:19fdeef40ada

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