Mercurial > urweb

annotate src/cjr_print.sml @ 1382:5cb95fb7d4d5

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