Mercurial > urweb

annotate src/cjr_print.sml @ 1415:e65082d76d26

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Only announce URI serving in standalone HTTP server (grandfathered into release!)
author Adam Chlipala <adam@chlipala.net>
date Sun, 23 Jan 2011 15:34:06 -0500
parents 7d963b8019e6
children 4a6f84092399
rev   line source
adam@1391 1 (* Copyright (c) 2008-2011, Adam Chlipala
adamc@29 2 * All rights reserved.
adamc@29 3 *
adamc@29 4 * Redistribution and use in source and binary forms, with or without
adamc@29 5 * modification, are permitted provided that the following conditions are met:
adamc@29 6 *
adamc@29 7 * - Redistributions of source code must retain the above copyright notice,
adamc@29 8 * this list of conditions and the following disclaimer.
adamc@29 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@29 10 * this list of conditions and the following disclaimer in the documentation
adamc@29 11 * and/or other materials provided with the distribution.
adamc@29 12 * - The names of contributors may not be used to endorse or promote products
adamc@29 13 * derived from this software without specific prior written permission.
adamc@29 14 *
adamc@29 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@29 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@29 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@29 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@29 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@29 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@29 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@29 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@29 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@29 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@29 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@29 26 *)
adamc@29 27
adamc@29 28 (* Pretty-printing C jr. *)
adamc@29 29
adamc@29 30 structure CjrPrint :> CJR_PRINT = struct
adamc@29 31
adamc@29 32 open Print.PD
adamc@29 33 open Print
adamc@29 34
adamc@29 35 open Cjr
adamc@29 36
adamc@269 37 val dummyt = (TRecord 0, ErrorMsg.dummySpan)
adamc@269 38
adamc@29 39 structure E = CjrEnv
adamc@29 40 structure EM = ErrorMsg
adamc@29 41
adamc@144 42 structure SK = struct
adamc@144 43 type ord_key = string
adamc@144 44 val compare = String.compare
adamc@144 45 end
adamc@144 46
adamc@144 47 structure SS = BinarySetFn(SK)
adamc@144 48 structure SM = BinaryMapFn(SK)
adamc@144 49 structure IS = IntBinarySet
adamc@144 50
adamc@144 51 structure CM = BinaryMapFn(struct
adamc@144 52 type ord_key = char
adamc@144 53 val compare = Char.compare
adamc@144 54 end)
adamc@144 55
adamc@29 56 val debug = ref false
adamc@29 57
adamc@196 58 val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan)
adamc@29 59
adamc@316 60 val ident = String.translate (fn #"'" => "PRIME"
adamc@316 61 | ch => str ch)
adamc@316 62
adamc@316 63 val p_ident = string o ident
adamc@316 64
adamc@463 65 fun isUnboxable (t : typ) =
adamc@463 66 case #1 t of
adamc@463 67 TDatatype (Default, _, _) => true
adamc@463 68 | TFfi ("Basis", "string") => true
adam@1370 69 | TFfi ("Basis", "queryString") => true
adamc@463 70 | _ => false
adamc@463 71
adamc@29 72 fun p_typ' par env (t, loc) =
adamc@29 73 case t of
adamc@476 74 TFun (t1, t2) => (EM.errorAt loc "Function type remains";
adamc@476 75 string "<FUNCTION>")
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
adam@1391 1322 fun potentiallyFancy (e, _) =
adam@1391 1323 case e of
adam@1391 1324 EPrim _ => false
adam@1391 1325 | ERel _ => false
adam@1391 1326 | ENamed _ => false
adam@1391 1327 | ECon (_, _, NONE) => false
adam@1391 1328 | ECon (_, _, SOME e) => potentiallyFancy e
adam@1391 1329 | ENone _ => false
adam@1391 1330 | ESome (_, e) => potentiallyFancy e
adam@1391 1331 | EFfi _ => false
adam@1391 1332 | EFfiApp _ => true
adam@1391 1333 | EApp _ => true
adam@1391 1334 | EUnop (_, e) => potentiallyFancy e
adam@1391 1335 | EBinop (_, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391 1336 | ERecord (_, xes) => List.exists (potentiallyFancy o #2) xes
adam@1391 1337 | EField (e, _) => potentiallyFancy e
adam@1391 1338 | ECase (e, pes, _) => potentiallyFancy e orelse List.exists (potentiallyFancy o #2) pes
adam@1391 1339 | EError _ => false
adam@1391 1340 | EReturnBlob _ => false
adam@1391 1341 | ERedirect _ => false
adam@1391 1342 | EWrite e => potentiallyFancy e
adam@1391 1343 | ESeq (e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391 1344 | ELet (_, _, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391 1345 | EQuery _ => true
adam@1391 1346 | EDml {dml = e, ...} => potentiallyFancy e
adam@1391 1347 | ENextval {seq = e, ...} => potentiallyFancy e
adam@1391 1348 | ESetval {seq = e1, count = e2} => potentiallyFancy e1 orelse potentiallyFancy e2
adam@1391 1349 | EUnurlify _ => true
adam@1391 1350
adamc@182 1351 fun p_exp' par env (e, loc) =
adamc@29 1352 case e of
adamc@276 1353 EPrim p => Prim.p_t_GCC p
adamc@29 1354 | ERel n => p_rel env n
adamc@109 1355 | ENamed n => p_enamed env n
adamc@188 1356 | ECon (Enum, pc, _) => p_patCon env pc
adamc@198 1357 | ECon (Option, pc, NONE) => string "NULL"
adamc@198 1358 | ECon (Option, pc, SOME e) =>
adamc@198 1359 let
adamc@198 1360 val to = case pc of
adamc@198 1361 PConVar n => #2 (E.lookupConstructor env n)
adamc@198 1362 | PConFfi {arg, ...} => arg
adamc@198 1363
adamc@198 1364 val t = case to of
adamc@198 1365 NONE => raise Fail "CjrPrint: ECon argument status mismatch"
adamc@198 1366 | SOME t => t
adamc@198 1367 in
adamc@463 1368 if isUnboxable t then
adamc@463 1369 p_exp' par env e
adamc@463 1370 else
adamc@463 1371 box [string "({",
adamc@463 1372 newline,
adamc@463 1373 p_typ env t,
adamc@463 1374 space,
adamc@463 1375 string "*tmp",
adamc@463 1376 space,
adamc@463 1377 string "=",
adamc@463 1378 space,
adamc@463 1379 string "uw_malloc(ctx, sizeof(",
adamc@463 1380 p_typ env t,
adamc@463 1381 string "));",
adamc@463 1382 newline,
adamc@463 1383 string "*tmp",
adamc@463 1384 space,
adamc@463 1385 string "=",
adamc@463 1386 p_exp' par env e,
adamc@463 1387 string ";",
adamc@463 1388 newline,
adamc@463 1389 string "tmp;",
adamc@463 1390 newline,
adamc@463 1391 string "})"]
adamc@198 1392 end
adamc@188 1393 | ECon (Default, pc, eo) =>
adamc@181 1394 let
adamc@196 1395 val (xd, xc, xn) = patConInfo env pc
adamc@181 1396 in
adamc@182 1397 box [string "({",
adamc@181 1398 newline,
adamc@181 1399 string "struct",
adamc@181 1400 space,
adamc@185 1401 string xd,
adamc@181 1402 space,
adamc@181 1403 string "*tmp",
adamc@181 1404 space,
adamc@181 1405 string "=",
adamc@181 1406 space,
adamc@311 1407 string "uw_malloc(ctx, sizeof(struct ",
adamc@185 1408 string xd,
adamc@181 1409 string "));",
adamc@181 1410 newline,
adamc@181 1411 string "tmp->tag",
adamc@181 1412 space,
adamc@181 1413 string "=",
adamc@181 1414 space,
adamc@185 1415 string xc,
adamc@181 1416 string ";",
adamc@181 1417 newline,
adamc@181 1418 case eo of
adamc@181 1419 NONE => box []
adamc@185 1420 | SOME e => box [string "tmp->data.",
adamc@196 1421 string xn,
adamc@181 1422 space,
adamc@181 1423 string "=",
adamc@181 1424 space,
adamc@181 1425 p_exp env e,
adamc@181 1426 string ";",
adamc@181 1427 newline],
adamc@181 1428 string "tmp;",
adamc@181 1429 newline,
adamc@181 1430 string "})"]
adamc@181 1431 end
adamc@297 1432 | ENone _ => string "NULL"
adamc@290 1433 | ESome (t, e) =>
adamc@463 1434 if isUnboxable t then
adamc@463 1435 p_exp' par env e
adamc@463 1436 else
adamc@463 1437 box [string "({",
adamc@463 1438 newline,
adamc@463 1439 p_typ env t,
adamc@463 1440 space,
adamc@463 1441 string "*tmp",
adamc@463 1442 space,
adamc@463 1443 string "=",
adamc@463 1444 space,
adamc@463 1445 string "uw_malloc(ctx, sizeof(",
adamc@463 1446 p_typ env t,
adamc@463 1447 string "));",
adamc@463 1448 newline,
adamc@463 1449 string "*tmp",
adamc@463 1450 space,
adamc@463 1451 string "=",
adamc@463 1452 p_exp' par env e,
adamc@463 1453 string ";",
adamc@463 1454 newline,
adamc@463 1455 string "tmp;",
adamc@463 1456 newline,
adamc@463 1457 string "})"]
adamc@109 1458
adamc@316 1459 | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
adamc@283 1460 | EError (e, t) =>
adamc@283 1461 box [string "({",
adamc@283 1462 newline,
adamc@283 1463 p_typ env t,
adamc@283 1464 space,
adamc@283 1465 string "tmp;",
adamc@283 1466 newline,
adamc@311 1467 string "uw_error(ctx, FATAL, \"",
adamc@292 1468 string (ErrorMsg.spanToString loc),
adamc@292 1469 string ": %s\", ",
adamc@283 1470 p_exp env e,
adamc@283 1471 string ");",
adamc@283 1472 newline,
adamc@283 1473 string "tmp;",
adamc@283 1474 newline,
adamc@283 1475 string "})"]
adamc@741 1476 | EReturnBlob {blob, mimeType, t} =>
adamc@741 1477 box [string "({",
adamc@741 1478 newline,
adamc@741 1479 p_typ env t,
adamc@741 1480 space,
adamc@741 1481 string "tmp;",
adamc@741 1482 newline,
adamc@741 1483 string "uw_return_blob(ctx, ",
adamc@741 1484 p_exp env blob,
adamc@741 1485 string ", ",
adamc@741 1486 p_exp env mimeType,
adamc@741 1487 string ");",
adamc@741 1488 newline,
adamc@741 1489 string "tmp;",
adamc@741 1490 newline,
adamc@741 1491 string "})"]
adamc@1065 1492 | ERedirect (e, t) =>
adamc@1065 1493 box [string "({",
adamc@1065 1494 newline,
adamc@1065 1495 p_typ env t,
adamc@1065 1496 space,
adamc@1065 1497 string "tmp;",
adamc@1065 1498 newline,
adamc@1065 1499 string "uw_redirect(ctx, ",
adamc@1065 1500 p_exp env e,
adamc@1065 1501 string ");",
adamc@1065 1502 newline,
adamc@1065 1503 string "tmp;",
adamc@1065 1504 newline,
adamc@1065 1505 string "})"]
adamc@476 1506 | EApp ((EError (e, (TFun (_, ran), _)), loc), _) =>
adamc@476 1507 p_exp env (EError (e, ran), loc)
adamc@741 1508 | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
adamc@741 1509 p_exp env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
adamc@476 1510
adamc@922 1511 | EFfiApp ("Basis", "strcat", [e1, e2]) =>
adamc@922 1512 let
adamc@922 1513 fun flatten e =
adamc@922 1514 case #1 e of
adamc@922 1515 EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2
adamc@922 1516 | _ => [e]
adamc@922 1517 in
adamc@922 1518 case flatten e1 @ flatten e2 of
adamc@922 1519 [e1, e2] => box [string "uw_Basis_strcat(ctx, ",
adamc@922 1520 p_exp env e1,
adamc@922 1521 string ",",
adamc@922 1522 p_exp env e2,
adamc@922 1523 string ")"]
adamc@922 1524 | es => box [string "uw_Basis_mstrcat(ctx, ",
adamc@922 1525 p_list (p_exp env) es,
adamc@922 1526 string ", NULL)"]
adamc@922 1527 end
adamc@922 1528
adamc@765 1529 | EFfiApp (m, x, []) => box [string "uw_",
adamc@765 1530 p_ident m,
adamc@765 1531 string "_",
adamc@765 1532 p_ident x,
adamc@765 1533 string "(ctx)"]
adamc@765 1534
adamc@311 1535 | EFfiApp (m, x, es) => box [string "uw_",
adamc@316 1536 p_ident m,
adamc@53 1537 string "_",
adamc@316 1538 p_ident x,
adamc@117 1539 string "(ctx, ",
adamc@53 1540 p_list (p_exp env) es,
adamc@53 1541 string ")"]
adamc@316 1542 | EApp (f, args) =>
adamc@316 1543 parenIf par (box [p_exp' true env f,
adamc@316 1544 string "(ctx,",
adamc@316 1545 space,
adamc@316 1546 p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@316 1547 string ")"])
adamc@29 1548
adamc@387 1549 | EUnop (s, e1) =>
adamc@387 1550 parenIf par (box [string s,
adamc@387 1551 space,
adamc@387 1552 p_exp' true env e1])
adamc@387 1553
adamc@387 1554 | EBinop (s, e1, e2) =>
adamc@389 1555 if Char.isAlpha (String.sub (s, size s - 1)) then
adamc@389 1556 box [string s,
adamc@390 1557 string "(",
adamc@389 1558 p_exp env e1,
adamc@389 1559 string ",",
adamc@389 1560 space,
adamc@389 1561 p_exp env e2,
adamc@389 1562 string ")"]
adamc@389 1563 else
adamc@389 1564 parenIf par (box [p_exp' true env e1,
adamc@389 1565 space,
adamc@389 1566 string s,
adamc@389 1567 space,
adamc@389 1568 p_exp' true env e2])
adamc@387 1569
adamc@29 1570 | ERecord (i, xes) => box [string "({",
adamc@29 1571 space,
adamc@29 1572 string "struct",
adamc@29 1573 space,
adamc@311 1574 string ("__uws_" ^ Int.toString i),
adamc@29 1575 space,
adamc@181 1576 string "tmp",
adamc@29 1577 space,
adamc@29 1578 string "=",
adamc@29 1579 space,
adamc@29 1580 string "{",
adamc@29 1581 p_list (fn (_, e) =>
adamc@29 1582 p_exp env e) xes,
adamc@29 1583 string "};",
adamc@29 1584 space,
adamc@181 1585 string "tmp;",
adamc@29 1586 space,
adamc@29 1587 string "})" ]
adamc@29 1588 | EField (e, x) =>
adamc@29 1589 box [p_exp' true env e,
adamc@311 1590 string ".__uwf_",
adamc@316 1591 p_ident x]
adamc@29 1592
adamc@182 1593 | ECase (e, pes, {disc, result}) =>
adamc@182 1594 let
adamc@182 1595 val final = newGoto ()
adamc@182 1596
adamc@182 1597 val body = foldl (fn ((p, e), body) =>
adamc@182 1598 let
adamc@182 1599 val exit = newGoto ()
adamc@182 1600 val (pr, _) = p_pat_preamble env p
adamc@182 1601 val (p, env) = p_pat (env,
adamc@182 1602 box [string "goto",
adamc@182 1603 space,
adamc@182 1604 exit,
adamc@182 1605 string ";"],
adamc@182 1606 0) p
adamc@182 1607 in
adamc@182 1608 box [body,
adamc@182 1609 box [string "{",
adamc@182 1610 newline,
adamc@182 1611 pr,
adamc@182 1612 newline,
adamc@182 1613 p,
adamc@182 1614 newline,
adamc@182 1615 string "result",
adamc@182 1616 space,
adamc@182 1617 string "=",
adamc@182 1618 space,
adamc@182 1619 p_exp env e,
adamc@182 1620 string ";",
adamc@182 1621 newline,
adamc@182 1622 string "goto",
adamc@182 1623 space,
adamc@182 1624 final,
adamc@182 1625 string ";",
adamc@182 1626 newline,
adamc@182 1627 string "}"],
adamc@182 1628 newline,
adamc@182 1629 exit,
adamc@182 1630 string ":",
adamc@182 1631 newline]
adamc@182 1632 end) (box []) pes
adamc@182 1633 in
adamc@182 1634 box [string "({",
adamc@182 1635 newline,
adamc@182 1636 p_typ env disc,
adamc@182 1637 space,
adamc@182 1638 string "disc0",
adamc@182 1639 space,
adamc@182 1640 string "=",
adamc@182 1641 space,
adamc@182 1642 p_exp env e,
adamc@182 1643 string ";",
adamc@182 1644 newline,
adamc@182 1645 p_typ env result,
adamc@182 1646 space,
adamc@182 1647 string "result;",
adamc@182 1648 newline,
adamc@182 1649 body,
adamc@311 1650 string "uw_error(ctx, FATAL, \"",
adamc@182 1651 string (ErrorMsg.spanToString loc),
adamc@182 1652 string ": pattern match failure\");",
adamc@182 1653 newline,
adamc@182 1654 final,
adamc@182 1655 string ":",
adamc@182 1656 space,
adamc@182 1657 string "result;",
adamc@182 1658 newline,
adamc@182 1659 string "})"]
adamc@182 1660 end
adamc@181 1661
adamc@311 1662 | EWrite e => box [string "(uw_write(ctx, ",
adamc@102 1663 p_exp env e,
adamc@311 1664 string "), uw_unit_v)"]
adamc@102 1665
adam@1391 1666 | ESeq (e1, e2) =>
adam@1391 1667 let
adam@1391 1668 val useRegion = potentiallyFancy e1
adam@1391 1669 in
adam@1391 1670 box [string "(",
adam@1391 1671 if useRegion then
adam@1391 1672 box [string "uw_begin_region(ctx),",
adam@1391 1673 space]
adam@1391 1674 else
adam@1391 1675 box [],
adam@1391 1676 p_exp env e1,
adam@1391 1677 string ",",
adam@1391 1678 space,
adam@1391 1679 if useRegion then
adam@1391 1680 box [string "uw_end_region(ctx),",
adam@1391 1681 space]
adam@1391 1682 else
adam@1391 1683 box [],
adam@1391 1684 p_exp env e2,
adam@1391 1685 string ")"]
adam@1391 1686 end
adam@1391 1687 | ELet (x, t, e1, e2) =>
adam@1391 1688 let
adam@1391 1689 val useRegion = notLeaky env false t andalso potentiallyFancy e1
adam@1391 1690 in
adam@1391 1691 box [string "({",
adam@1391 1692 newline,
adam@1391 1693 p_typ env t,
adam@1391 1694 space,
adam@1391 1695 string "__uwr_",
adam@1391 1696 p_ident x,
adam@1391 1697 string "_",
adam@1391 1698 string (Int.toString (E.countERels env)),
adam@1391 1699 space,
adam@1391 1700 string "=",
adam@1391 1701 space,
adam@1391 1702 if useRegion then
adam@1391 1703 box [string "(uw_begin_region(ctx),",
adam@1391 1704 space]
adam@1391 1705 else
adam@1391 1706 box [],
adam@1391 1707 p_exp env e1,
adam@1391 1708 if useRegion then
adam@1391 1709 string ")"
adam@1391 1710 else
adam@1391 1711 box [],
adam@1391 1712 string ";",
adam@1391 1713 newline,
adam@1391 1714 if useRegion then
adam@1391 1715 box [string "uw_end_region(ctx);",
adam@1391 1716 newline]
adam@1391 1717 else
adam@1391 1718 box [],
adam@1391 1719 p_exp (E.pushERel env x t) e2,
adam@1391 1720 string ";",
adam@1391 1721 newline,
adam@1391 1722 string "})"]
adam@1391 1723 end
adamc@269 1724
adamc@282 1725 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
adamc@278 1726 let
adamc@316 1727 val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps
adamc@278 1728 val tables = ListUtil.mapConcat (fn (x, xts) =>
adamc@316 1729 map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
adamc@278 1730 tables
adamc@638 1731
adamc@1168 1732 val sort = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
adamc@1168 1733 val outputs = sort exps @ sort tables
adamc@324 1734
adamc@324 1735 val wontLeakStrings = notLeaky env true state
adamc@324 1736 val wontLeakAnything = notLeaky env false state
adamc@867 1737
adamc@867 1738 val inputs =
adamc@867 1739 case prepared of
adamc@867 1740 NONE => []
adamc@867 1741 | SOME _ => getPargs query
adamc@867 1742
adamc@867 1743 fun doCols p_getcol =
adamc@867 1744 box [string "struct __uws_",
adamc@867 1745 string (Int.toString rnum),
adamc@867 1746 string " __uwr_r_",
adamc@867 1747 string (Int.toString (E.countERels env)),
adamc@867 1748 string ";",
adamc@867 1749 newline,
adamc@867 1750 p_typ env state,
adamc@867 1751 space,
adamc@867 1752 string "__uwr_acc_",
adamc@867 1753 string (Int.toString (E.countERels env + 1)),
adamc@867 1754 space,
adamc@867 1755 string "=",
adamc@867 1756 space,
adamc@867 1757 string "acc;",
adamc@867 1758 newline,
adamc@867 1759 newline,
adamc@1114 1760
adamc@1114 1761 if Settings.getDeadlines () then
adamc@1114 1762 box [string "uw_check_deadline(ctx);",
adamc@1114 1763 newline]
adamc@1114 1764 else
adamc@1114 1765 box [],
adamc@1114 1766
adamc@867 1767 p_list_sepi (box []) (fn i =>
adamc@867 1768 fn (proj, t) =>
adamc@867 1769 box [string "__uwr_r_",
adamc@867 1770 string (Int.toString (E.countERels env)),
adamc@867 1771 string ".",
adamc@867 1772 string proj,
adamc@867 1773 space,
adamc@867 1774 string "=",
adamc@867 1775 space,
adamc@880 1776 p_getcol {loc = loc,
adamc@880 1777 wontLeakStrings = wontLeakStrings,
adamc@867 1778 col = i,
adamc@867 1779 typ = sql_type_in env t},
adamc@867 1780 string ";",
adamc@867 1781 newline]) outputs,
adamc@867 1782 newline,
adamc@867 1783 newline,
adamc@867 1784
adamc@867 1785 string "acc",
adamc@867 1786 space,
adamc@867 1787 string "=",
adamc@867 1788 space,
adamc@867 1789 p_exp (E.pushERel
adamc@867 1790 (E.pushERel env "r" (TRecord rnum, loc))
adamc@867 1791 "acc" state)
adamc@867 1792 body,
adamc@867 1793 string ";",
adamc@867 1794 newline]
adamc@278 1795 in
adamc@640 1796 box [if wontLeakAnything then
adamc@704 1797 string "(uw_begin_region(ctx), "
adamc@324 1798 else
adamc@324 1799 box [],
adamc@324 1800 string "({",
adamc@278 1801 newline,
adamc@640 1802 p_typ env state,
adamc@640 1803 space,
adamc@640 1804 string "acc",
adamc@640 1805 space,
adamc@640 1806 string "=",
adamc@640 1807 space,
adamc@640 1808 p_exp env initial,
adamc@640 1809 string ";",
adamc@640 1810 newline,
adamc@867 1811 string "int dummy = (uw_begin_region(ctx), 0);",
adamc@640 1812 newline,
adamc@640 1813
adamc@282 1814 case prepared of
adamc@867 1815 NONE =>
adamc@867 1816 box [string "char *query = ",
adamc@867 1817 p_exp env query,
adamc@867 1818 string ";",
adamc@867 1819 newline,
adamc@867 1820 newline,
adamc@282 1821
adamc@867 1822 #query (Settings.currentDbms ())
adamc@867 1823 {loc = loc,
adamc@873 1824 cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@867 1825 doCols = doCols}]
adamc@879 1826 | SOME {id, query, nested} =>
adamc@867 1827 box [p_list_sepi newline
adamc@867 1828 (fn i => fn (e, t) =>
adamc@867 1829 box [p_sql_type t,
adamc@867 1830 space,
adamc@867 1831 string "arg",
adamc@867 1832 string (Int.toString (i + 1)),
adamc@867 1833 space,
adamc@867 1834 string "=",
adamc@867 1835 space,
adamc@867 1836 p_exp env e,
adamc@867 1837 string ";"])
adamc@867 1838 inputs,
adamc@867 1839 newline,
adamc@867 1840 newline,
adamc@640 1841
adamc@867 1842 #queryPrepared (Settings.currentDbms ())
adamc@867 1843 {loc = loc,
adamc@867 1844 id = id,
adamc@867 1845 query = query,
adamc@867 1846 inputs = map #2 inputs,
adamc@873 1847 cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@879 1848 doCols = doCols,
adamc@879 1849 nested = nested}],
adamc@278 1850 newline,
adamc@277 1851
adamc@324 1852 if wontLeakAnything then
adamc@324 1853 box [string "uw_end_region(ctx);",
adamc@324 1854 newline]
adamc@324 1855 else
adamc@324 1856 box [],
adamc@278 1857 string "acc;",
adamc@278 1858 newline,
adamc@704 1859 string "})",
adamc@704 1860 if wontLeakAnything then
adamc@704 1861 string ")"
adamc@704 1862 else
adamc@704 1863 box []]
adamc@278 1864 end
adamc@106 1865
adam@1293 1866 | EDml {dml, prepared, mode} =>
adam@1295 1867 box [string "(uw_begin_region(ctx), ({",
adamc@307 1868 newline,
adamc@307 1869 case prepared of
adamc@307 1870 NONE => box [string "char *dml = ",
adamc@307 1871 p_exp env dml,
adamc@307 1872 string ";",
adamc@868 1873 newline,
adamc@868 1874 newline,
adam@1293 1875 #dml (Settings.currentDbms ()) (loc, mode)]
adamc@879 1876 | SOME {id, dml = dml'} =>
adamc@307 1877 let
adamc@868 1878 val inputs = getPargs dml
adamc@307 1879 in
adamc@307 1880 box [p_list_sepi newline
adamc@307 1881 (fn i => fn (e, t) =>
adamc@307 1882 box [p_sql_type t,
adamc@307 1883 space,
adamc@307 1884 string "arg",
adamc@307 1885 string (Int.toString (i + 1)),
adamc@307 1886 space,
adamc@307 1887 string "=",
adamc@307 1888 space,
adamc@307 1889 p_exp env e,
adamc@307 1890 string ";"])
adamc@868 1891 inputs,
adamc@307 1892 newline,
adamc@307 1893 newline,
adamc@307 1894
adamc@868 1895 #dmlPrepared (Settings.currentDbms ()) {loc = loc,
adamc@868 1896 id = id,
adamc@868 1897 dml = dml',
adam@1293 1898 inputs = map #2 inputs,
adam@1293 1899 mode = mode}]
adamc@307 1900 end,
adamc@307 1901 newline,
adamc@307 1902 newline,
adamc@337 1903 string "uw_end_region(ctx);",
adamc@337 1904 newline,
adam@1293 1905
adam@1293 1906 case mode of
adam@1293 1907 Settings.Error => string "uw_unit_v;"
adam@1295 1908 | Settings.None => string "uw_dup_and_clear_error_message(ctx);",
adam@1293 1909
adamc@307 1910 newline,
adam@1295 1911 string "}))"]
adamc@307 1912
adamc@338 1913 | ENextval {seq, prepared} =>
adamc@878 1914 box [string "({",
adamc@878 1915 newline,
adamc@878 1916 string "uw_Basis_int n;",
adamc@878 1917 newline,
adamc@869 1918
adamc@878 1919 case prepared of
adamc@878 1920 NONE => #nextval (Settings.currentDbms ()) {loc = loc,
adamc@878 1921 seqE = p_exp env seq,
adamc@878 1922 seqName = case #1 seq of
adamc@878 1923 EPrim (Prim.String s) => SOME s
adamc@878 1924 | _ => NONE}
adamc@879 1925 | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
adamc@878 1926 id = id,
adamc@878 1927 query = query},
adamc@878 1928 newline,
adamc@878 1929 newline,
adamc@869 1930
adamc@878 1931 string "n;",
adamc@878 1932 newline,
adamc@878 1933 string "})"]
adamc@338 1934
adamc@1073 1935 | ESetval {seq, count} =>
adamc@1073 1936 box [string "({",
adamc@1073 1937 newline,
adamc@1073 1938
adamc@1073 1939 #setval (Settings.currentDbms ()) {loc = loc,
adamc@1073 1940 seqE = p_exp env seq,
adamc@1073 1941 count = p_exp env count},
adamc@1073 1942 newline,
adamc@1073 1943 newline,
adamc@1073 1944
adamc@1073 1945 string "uw_unit_v;",
adamc@1073 1946 newline,
adamc@1073 1947 string "})"]
adamc@1073 1948
adamc@1112 1949 | EUnurlify (e, t, true) =>
adamc@463 1950 let
adamc@463 1951 fun getIt () =
adamc@463 1952 if isUnboxable t then
adamc@1023 1953 unurlify false env t
adamc@463 1954 else
adamc@463 1955 box [string "({",
adamc@463 1956 newline,
adamc@463 1957 p_typ env t,
adamc@463 1958 string " *tmp = uw_malloc(ctx, sizeof(",
adamc@463 1959 p_typ env t,
adamc@463 1960 string "));",
adamc@463 1961 newline,
adamc@463 1962 string "*tmp = ",
adamc@1023 1963 unurlify false env t,
adamc@463 1964 string ";",
adamc@463 1965 newline,
adamc@463 1966 string "tmp;",
adamc@463 1967 newline,
adamc@463 1968 string "})"]
adamc@463 1969 in
adamc@463 1970 box [string "({",
adamc@463 1971 newline,
adamc@737 1972 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
adamc@463 1973 p_exp env e,
adamc@492 1974 string ");",
adamc@463 1975 newline,
adamc@463 1976 newline,
adamc@463 1977 string "(request ? ",
adamc@463 1978 getIt (),
adamc@463 1979 string " : NULL);",
adamc@463 1980 newline,
adamc@463 1981 string "})"]
adamc@463 1982 end
adamc@463 1983
adamc@1112 1984 | EUnurlify (e, t, false) =>
adamc@1112 1985 let
adamc@1112 1986 fun getIt () =
adamc@1112 1987 if isUnboxable t then
adamc@1112 1988 unurlify false env t
adamc@1112 1989 else
adamc@1112 1990 box [string "({",
adamc@1112 1991 newline,
adamc@1112 1992 p_typ env t,
adamc@1112 1993 string " *tmp = uw_malloc(ctx, sizeof(",
adamc@1112 1994 p_typ env t,
adamc@1112 1995 string "));",
adamc@1112 1996 newline,
adamc@1112 1997 string "*tmp = ",
adamc@1112 1998 unurlify false env t,
adamc@1112 1999 string ";",
adamc@1112 2000 newline,
adamc@1112 2001 string "tmp;",
adamc@1112 2002 newline,
adamc@1112 2003 string "})"]
adamc@1112 2004 in
adamc@1112 2005 box [string "({",
adamc@1112 2006 newline,
adamc@1112 2007 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
adamc@1112 2008 p_exp env e,
adamc@1112 2009 string ");",
adamc@1112 2010 newline,
adamc@1112 2011 newline,
adamc@1112 2012 unurlify false env t,
adamc@1112 2013 string ";",
adamc@1112 2014 newline,
adamc@1112 2015 string "})"]
adamc@1112 2016 end
adamc@1112 2017
adamc@29 2018 and p_exp env = p_exp' false env
adamc@29 2019
adamc@1114 2020 fun p_fun isRec env (fx, n, args, ran, e) =
adamc@129 2021 let
adamc@129 2022 val nargs = length args
adamc@129 2023 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 2024 in
adamc@129 2025 box [string "static",
adamc@129 2026 space,
adamc@129 2027 p_typ env ran,
adamc@129 2028 space,
adamc@316 2029 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
adamc@129 2030 string "(",
adamc@129 2031 p_list_sep (box [string ",", space]) (fn x => x)
adamc@311 2032 (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 2033 box [p_typ env dom,
adamc@129 2034 space,
adamc@129 2035 p_rel env' (nargs - i - 1)]) args),
adamc@129 2036 string ")",
adamc@129 2037 space,
adamc@129 2038 string "{",
adamc@129 2039 newline,
adamc@1114 2040 if isRec andalso Settings.getDeadlines () then
adamc@1114 2041 box [string "uw_check_deadline(ctx);",
adamc@1114 2042 newline]
adamc@1114 2043 else
adamc@1114 2044 box [],
adamc@638 2045 box [string "return(",
adamc@638 2046 p_exp env' e,
adamc@638 2047 string ");"],
adamc@129 2048 newline,
adamc@129 2049 string "}"]
adamc@129 2050 end
adamc@129 2051
adamc@129 2052 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 2053 case d of
adamc@29 2054 DStruct (n, xts) =>
adamc@196 2055 let
adamc@196 2056 val env = E.declBinds env dAll
adamc@196 2057 in
adamc@196 2058 box [string "struct",
adamc@196 2059 space,
adamc@311 2060 string ("__uws_" ^ Int.toString n),
adamc@196 2061 space,
adamc@196 2062 string "{",
adamc@196 2063 newline,
adamc@196 2064 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@196 2065 space,
adamc@311 2066 string "__uwf_",
adamc@316 2067 p_ident x,
adamc@196 2068 string ";",
adamc@196 2069 newline]) xts,
adamc@196 2070 string "};"]
adamc@196 2071 end
adamc@809 2072 | DDatatype dts =>
adamc@165 2073 let
adamc@809 2074 val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) =>
adamc@809 2075 dk1 = Enum andalso dk2 <> Enum) dts
adamc@809 2076
adamc@809 2077 fun p_one (Enum, x, n, xncs) =
adamc@809 2078 box [string "enum",
adamc@809 2079 space,
adamc@809 2080 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2081 space,
adamc@809 2082 string "{",
adamc@809 2083 space,
adam@1298 2084 case xncs of
adam@1298 2085 [] => string ("__uwec_" ^ ident x ^ "_" ^ Int.toString n)
adam@1298 2086 | _ =>
adam@1298 2087 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adam@1298 2088 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
adamc@809 2089 space,
adamc@809 2090 string "};"]
adamc@809 2091 | p_one (Option, _, _, _) = box []
adamc@809 2092 | p_one (Default, x, n, xncs) =
adamc@809 2093 let
adamc@809 2094 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@809 2095 | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@809 2096 in
adamc@809 2097 box [string "enum",
adamc@809 2098 space,
adamc@809 2099 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2100 space,
adamc@809 2101 string "{",
adamc@809 2102 space,
adamc@809 2103 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adamc@809 2104 string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n))
adamc@809 2105 xncs,
adamc@809 2106 space,
adamc@809 2107 string "};",
adamc@809 2108 newline,
adamc@809 2109 newline,
adamc@809 2110 string "struct",
adamc@809 2111 space,
adamc@809 2112 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2113 space,
adamc@809 2114 string "{",
adamc@809 2115 newline,
adamc@809 2116 string "enum",
adamc@809 2117 space,
adamc@809 2118 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809 2119 space,
adamc@809 2120 string "tag;",
adamc@809 2121 newline,
adamc@809 2122 box (case xncsArgs of
adamc@809 2123 [] => []
adamc@809 2124 | _ => [string "union",
adamc@809 2125 space,
adamc@809 2126 string "{",
adamc@809 2127 newline,
adamc@809 2128 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@809 2129 space,
adamc@809 2130 string ("uw_" ^ ident x),
adamc@809 2131 string ";"]) xncsArgs,
adamc@809 2132 newline,
adamc@809 2133 string "}",
adamc@809 2134 space,
adamc@809 2135 string "data;",
adamc@809 2136 newline]),
adamc@809 2137 string "};"]
adamc@809 2138 end
adamc@165 2139 in
adamc@809 2140 p_list_sep (box []) p_one dts
adamc@188 2141 end
adamc@29 2142
adamc@196 2143 | DDatatypeForward _ => box []
adamc@196 2144
adamc@29 2145 | DVal (x, n, t, e) =>
adamc@29 2146 box [p_typ env t,
adamc@29 2147 space,
adamc@316 2148 string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n),
adamc@29 2149 space,
adamc@29 2150 string "=",
adamc@29 2151 space,
adamc@29 2152 p_exp env e,
adamc@29 2153 string ";"]
adamc@1114 2154 | DFun vi => p_fun false env vi
adamc@129 2155 | DFunRec vis =>
adamc@29 2156 let
adamc@129 2157 val env = E.declBinds env dAll
adamc@29 2158 in
adamc@129 2159 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 2160 box [string "static",
adamc@129 2161 space,
adamc@129 2162 p_typ env ran,
adamc@129 2163 space,
adamc@316 2164 string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
adamc@311 2165 string "(uw_context,",
adamc@129 2166 space,
adamc@129 2167 p_list_sep (box [string ",", space])
adamc@129 2168 (fn (_, dom) => p_typ env dom) args,
adamc@129 2169 string ");"]) vis,
adamc@29 2170 newline,
adamc@1114 2171 p_list_sep newline (p_fun true env) vis,
adamc@129 2172 newline]
adamc@29 2173 end
adamc@707 2174 | DTable (x, _, pk, csts) => box [string "/* SQL table ",
adamc@707 2175 string x,
adamc@707 2176 space,
adamc@707 2177 case pk of
adamc@707 2178 "" => box []
adamc@707 2179 | _ => box [string "keys",
adamc@707 2180 space,
adamc@707 2181 string pk,
adamc@707 2182 space],
adamc@707 2183 string "constraints",
adamc@707 2184 space,
adamc@707 2185 p_list (fn (x, v) => box [string x,
adamc@707 2186 space,
adamc@707 2187 string ":",
adamc@707 2188 space,
adamc@707 2189 string v]) csts,
adamc@707 2190 space,
adamc@707 2191 string " */",
adamc@707 2192 newline]
adamc@338 2193 | DSequence x => box [string "/* SQL sequence ",
adamc@338 2194 string x,
adamc@338 2195 string " */",
adamc@338 2196 newline]
adamc@754 2197 | DView (x, _, s) => box [string "/* SQL view ",
adamc@754 2198 string x,
adamc@754 2199 space,
adamc@754 2200 string "AS",
adamc@754 2201 space,
adamc@754 2202 string s,
adamc@754 2203 space,
adamc@754 2204 string " */",
adamc@754 2205 newline]
adamc@870 2206 | DDatabase _ => box []
adamc@870 2207 | DPreparedStatements _ => box []
adamc@282 2208
adamc@569 2209 | DJavaScript s => box [string "static char jslib[] = \"",
adam@1285 2210 string (String.toCString s),
adamc@569 2211 string "\";"]
adamc@725 2212 | DCookie s => box [string "/*",
adamc@725 2213 space,
adamc@725 2214 string "cookie",
adamc@725 2215 space,
adamc@725 2216 string s,
adamc@725 2217 space,
adamc@725 2218 string "*/"]
adamc@720 2219 | DStyle s => box [string "/*",
adamc@720 2220 space,
adamc@720 2221 string "style",
adamc@720 2222 space,
adamc@720 2223 string s,
adamc@720 2224 space,
adamc@720 2225 string "*/"]
adamc@569 2226
adamc@1075 2227 | DTask _ => box []
adam@1294 2228 | DOnError _ => box []
adamc@1073 2229
adamc@144 2230 datatype 'a search =
adamc@144 2231 Found of 'a
adamc@144 2232 | NotFound
adamc@144 2233 | Error
adamc@120 2234
adamc@467 2235 fun p_sqltype'' env (tAll as (t, loc)) =
adamc@275 2236 case t of
adamc@275 2237 TFfi ("Basis", "int") => "int8"
adamc@275 2238 | TFfi ("Basis", "float") => "float8"
adamc@275 2239 | TFfi ("Basis", "string") => "text"
adamc@275 2240 | TFfi ("Basis", "bool") => "bool"
adamc@438 2241 | TFfi ("Basis", "time") => "timestamp"
adamc@737 2242 | TFfi ("Basis", "blob") => "bytea"
adamc@682 2243 | TFfi ("Basis", "channel") => "int8"
adamc@682 2244 | TFfi ("Basis", "client") => "int4"
adamc@275 2245 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
adamc@275 2246 Print.eprefaces' [("Type", p_typ env tAll)];
adamc@275 2247 "ERROR")
adamc@275 2248
adamc@467 2249 fun p_sqltype' env (tAll as (t, loc)) =
adamc@467 2250 case t of
adamc@467 2251 (TOption t, _) => p_sqltype'' env t
adamc@467 2252 | _ => p_sqltype'' env t ^ " NOT NULL"
adamc@467 2253
adamc@275 2254 fun p_sqltype env t = string (p_sqltype' env t)
adamc@101 2255
adamc@467 2256 fun p_sqltype_base' env t =
adamc@467 2257 case t of
adamc@467 2258 (TOption t, _) => p_sqltype'' env t
adamc@467 2259 | _ => p_sqltype'' env t
adamc@467 2260
adamc@467 2261 fun p_sqltype_base env t = string (p_sqltype_base' env t)
adamc@467 2262
adamc@467 2263 fun is_not_null t =
adamc@467 2264 case t of
adamc@467 2265 (TOption _, _) => false
adamc@467 2266 | _ => true
adamc@467 2267
adamc@734 2268 fun sigName fields =
adamc@734 2269 let
adamc@734 2270 fun inFields s = List.exists (fn (s', _) => s' = s) fields
adamc@734 2271
adamc@734 2272 fun getSigName n =
adamc@734 2273 let
adamc@734 2274 val s = "Sig" ^ Int.toString n
adamc@734 2275 in
adamc@734 2276 if inFields s then
adamc@734 2277 getSigName (n + 1)
adamc@734 2278 else
adamc@734 2279 s
adamc@734 2280 end
adamc@734 2281 in
adamc@734 2282 if inFields "Sig" then
adamc@734 2283 getSigName 0
adamc@734 2284 else
adamc@734 2285 "Sig"
adamc@734 2286 end
adamc@734 2287
adamc@101 2288 fun p_file env (ds, ps) =
adamc@29 2289 let
adamc@101 2290 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@638 2291 (p_decl env d,
adamc@638 2292 E.declBinds env d))
adamc@101 2293 env ds
adamc@144 2294
adamc@779 2295 fun flatFields always (t : typ) =
adamc@756 2296 case #1 t of
adamc@756 2297 TRecord i =>
adamc@756 2298 let
adamc@756 2299 val xts = E.lookupStruct env i
adamc@756 2300 in
adamc@779 2301 SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts))
adamc@756 2302 end
adamc@759 2303 | TList (_, i) =>
adamc@759 2304 let
adamc@759 2305 val ts = E.lookupStruct env i
adamc@759 2306 in
adamc@759 2307 case ts of
adamc@779 2308 [("1", t'), ("2", _)] => flatFields [] t'
adamc@759 2309 | _ => raise Fail "CjrPrint: Bad struct for TList"
adamc@759 2310 end
adamc@756 2311 | _ => NONE
adamc@756 2312
adamc@1104 2313 val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) =>
adamc@144 2314 case ek of
adam@1347 2315 Action eff =>
adam@1347 2316 (case List.nth (ts, length ts - 2) of
adam@1347 2317 (TRecord i, loc) =>
adam@1347 2318 let
adam@1347 2319 val xts = E.lookupStruct env i
adam@1347 2320 val extra = case eff of
adam@1347 2321 ReadCookieWrite => [sigName xts]
adam@1347 2322 | _ => []
adam@1347 2323 in
adam@1347 2324 case flatFields extra (TRecord i, loc) of
adam@1347 2325 NONE => raise Fail "CjrPrint: flatFields impossible"
adam@1347 2326 | SOME fields' => List.revAppend (fields', fields)
adam@1347 2327 end
adam@1347 2328 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adam@1347 2329 | _ => fields)
adamc@756 2330 [] ps
adamc@756 2331
adamc@756 2332 val fields = foldl (fn (xts, fields) =>
adamc@756 2333 let
adamc@756 2334 val xtsSet = SS.addList (SS.empty, xts)
adamc@756 2335 in
adamc@756 2336 foldl (fn (x, fields) =>
adamc@756 2337 let
adamc@756 2338 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@756 2339 in
adamc@756 2340 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@756 2341 xtsSet'))
adamc@756 2342 end) fields xts
adamc@756 2343 end)
adamc@756 2344 SM.empty fields
adamc@144 2345
adamc@144 2346 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144 2347 let
adamc@144 2348 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144 2349 case SM.find (fnums, x') of
adamc@144 2350 NONE => unusable
adamc@144 2351 | SOME n => IS.add (unusable, n))
adamc@144 2352 IS.empty xs
adamc@144 2353
adamc@144 2354 fun findAvailable n =
adamc@144 2355 if IS.member (unusable, n) then
adamc@144 2356 findAvailable (n + 1)
adamc@144 2357 else
adamc@144 2358 n
adamc@144 2359 in
adamc@144 2360 SM.insert (fnums, x, findAvailable 0)
adamc@144 2361 end)
adamc@144 2362 SM.empty fields
adamc@144 2363
adamc@734 2364 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
adamc@734 2365
adamc@144 2366 fun makeSwitch (fnums, i) =
adamc@144 2367 case SM.foldl (fn (n, NotFound) => Found n
adamc@144 2368 | (n, Error) => Error
adamc@144 2369 | (n, Found n') => if n = n' then
adamc@144 2370 Found n'
adamc@144 2371 else
adamc@144 2372 Error) NotFound fnums of
adamc@144 2373 NotFound => box [string "return",
adamc@144 2374 space,
adamc@144 2375 string "-1;"]
adamc@144 2376 | Found n => box [string "return",
adamc@144 2377 space,
adamc@144 2378 string (Int.toString n),
adamc@144 2379 string ";"]
adamc@144 2380 | Error =>
adamc@144 2381 let
adamc@144 2382 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144 2383 let
adamc@144 2384 val ch = if i < size x then
adamc@144 2385 String.sub (x, i)
adamc@144 2386 else
adamc@144 2387 chr 0
adamc@144 2388
adamc@144 2389 val fnums = case CM.find (cmap, ch) of
adamc@144 2390 NONE => SM.empty
adamc@144 2391 | SOME fnums => fnums
adamc@144 2392 val fnums = SM.insert (fnums, x, n)
adamc@144 2393 in
adamc@144 2394 CM.insert (cmap, ch, fnums)
adamc@144 2395 end)
adamc@144 2396 CM.empty fnums
adamc@144 2397
adamc@144 2398 val cmap = CM.listItemsi cmap
adamc@144 2399 in
adamc@144 2400 case cmap of
adamc@144 2401 [(_, fnums)] =>
adamc@144 2402 box [string "if",
adamc@144 2403 space,
adamc@144 2404 string "(name[",
adamc@144 2405 string (Int.toString i),
adamc@144 2406 string "]",
adamc@144 2407 space,
adamc@144 2408 string "==",
adamc@144 2409 space,
adamc@144 2410 string "0)",
adamc@144 2411 space,
adamc@144 2412 string "return",
adamc@144 2413 space,
adamc@144 2414 string "-1;",
adamc@144 2415 newline,
adamc@144 2416 makeSwitch (fnums, i+1)]
adamc@144 2417 | _ =>
adamc@144 2418 box [string "switch",
adamc@144 2419 space,
adamc@144 2420 string "(name[",
adamc@144 2421 string (Int.toString i),
adamc@144 2422 string "])",
adamc@144 2423 space,
adamc@144 2424 string "{",
adamc@144 2425 newline,
adamc@144 2426 box (map (fn (ch, fnums) =>
adamc@144 2427 box [string "case",
adamc@144 2428 space,
adamc@144 2429 if ch = chr 0 then
adamc@144 2430 string "0:"
adamc@144 2431 else
adamc@144 2432 box [string "'",
adamc@144 2433 string (Char.toString ch),
adamc@144 2434 string "':"],
adamc@144 2435 newline,
adamc@144 2436 makeSwitch (fnums, i+1),
adamc@144 2437 newline]) cmap),
adamc@144 2438 string "default:",
adamc@144 2439 newline,
adamc@144 2440 string "return",
adamc@144 2441 space,
adamc@144 2442 string "-1;",
adamc@144 2443 newline,
adamc@144 2444 string "}"]
adamc@144 2445 end
adamc@144 2446
adamc@756 2447 fun getInput (x, t) =
adamc@756 2448 let
adamc@756 2449 val n = case SM.find (fnums, x) of
adamc@759 2450 NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums")
adamc@756 2451 | SOME n => n
adamc@756 2452
adamc@756 2453 val f = case t of
adamc@756 2454 (TFfi ("Basis", "bool"), _) => "optional_"
adamc@756 2455 | _ => ""
adamc@756 2456 in
adamc@756 2457 if isFile t then
adamc@756 2458 box [string "uw_input_",
adamc@756 2459 p_ident x,
adamc@756 2460 space,
adamc@756 2461 string "=",
adamc@756 2462 space,
adamc@756 2463 string "uw_get_file_input(ctx, ",
adamc@756 2464 string (Int.toString n),
adamc@756 2465 string ");",
adamc@756 2466 newline]
adamc@756 2467 else case #1 t of
adamc@756 2468 TRecord i =>
adamc@756 2469 let
adamc@756 2470 val xts = E.lookupStruct env i
adamc@756 2471 in
adamc@756 2472 box [string "uw_enter_subform(ctx, ",
adamc@756 2473 string (Int.toString n),
adamc@756 2474 string ");",
adamc@756 2475 newline,
adamc@756 2476 string "uw_input_",
adamc@756 2477 p_ident x,
adamc@756 2478 space,
adamc@756 2479 string "=",
adamc@756 2480 space,
adamc@756 2481 string "({",
adamc@756 2482 box [p_typ env t,
adamc@756 2483 space,
adamc@756 2484 string "result;",
adamc@756 2485 newline,
adamc@756 2486 p_list_sep (box [])
adamc@756 2487 (fn (x, t) =>
adamc@756 2488 box [p_typ env t,
adamc@756 2489 space,
adamc@756 2490 string "uw_input_",
adamc@756 2491 string x,
adamc@756 2492 string ";",
adamc@756 2493 newline])
adamc@756 2494 xts,
adamc@756 2495 newline,
adamc@756 2496 p_list_sep (box []) (fn (x, t) =>
adamc@756 2497 box [getInput (x, t),
adamc@756 2498 string "result.__uwf_",
adamc@756 2499 string x,
adamc@756 2500 space,
adamc@756 2501 string "=",
adamc@756 2502 space,
adamc@756 2503 string "uw_input_",
adamc@756 2504 string x,
adamc@756 2505 string ";",
adamc@756 2506 newline])
adamc@756 2507 xts,
adamc@756 2508 newline,
adamc@756 2509 string "result;",
adamc@756 2510 newline],
adamc@756 2511 string "});",
adamc@756 2512 newline,
adamc@756 2513 string "uw_leave_subform(ctx);"]
adamc@756 2514 end
adamc@759 2515 | TList (t', i) =>
adamc@759 2516 let
adamc@759 2517 val xts = E.lookupStruct env i
adamc@759 2518 val i' = case xts of
adamc@759 2519 [("1", (TRecord i', loc)), ("2", _)] => i'
adamc@759 2520 | _ => raise Fail "CjrPrint: Bad TList record [2]"
adamc@759 2521 val xts = E.lookupStruct env i'
adamc@759 2522 in
adamc@759 2523 box [string "{",
adamc@759 2524 newline,
adamc@759 2525 string "int status;",
adamc@759 2526 newline,
adamc@759 2527 string "uw_input_",
adamc@759 2528 p_ident x,
adamc@759 2529 space,
adamc@759 2530 string "=",
adamc@759 2531 space,
adamc@759 2532 string "NULL;",
adamc@759 2533 newline,
adamc@759 2534 string "for (status = uw_enter_subforms(ctx, ",
adamc@759 2535 string (Int.toString n),
adamc@759 2536 string "); status; status = uw_next_entry(ctx)) {",
adamc@759 2537 newline,
adamc@759 2538 box [p_typ env t,
adamc@759 2539 space,
adamc@759 2540 string "result",
adamc@759 2541 space,
adamc@759 2542 string "=",
adamc@759 2543 space,
adamc@759 2544 string "uw_malloc(ctx, sizeof(struct __uws_",
adamc@759 2545 string (Int.toString i),
adamc@759 2546 string "));",
adamc@759 2547 newline,
adamc@759 2548 box [string "{",
adamc@759 2549 p_list_sep (box [])
adamc@759 2550 (fn (x, t) =>
adamc@759 2551 box [p_typ env t,
adamc@759 2552 space,
adamc@759 2553 string "uw_input_",
adamc@759 2554 string x,
adamc@759 2555 string ";",
adamc@759 2556 newline])
adamc@759 2557 xts,
adamc@759 2558 newline,
adamc@759 2559 p_list_sep (box []) (fn (x, t) =>
adamc@759 2560 box [getInput (x, t),
adamc@759 2561 string "result->__uwf_1.__uwf_",
adamc@759 2562 string x,
adamc@759 2563 space,
adamc@759 2564 string "=",
adamc@759 2565 space,
adamc@759 2566 string "uw_input_",
adamc@759 2567 string x,
adamc@759 2568 string ";",
adamc@759 2569 newline])
adamc@759 2570 xts,
adamc@759 2571 string "}",
adamc@759 2572 newline],
adamc@759 2573 newline,
adamc@759 2574 string "result->__uwf_2 = uw_input_",
adamc@759 2575 p_ident x,
adamc@759 2576 string ";",
adamc@759 2577 newline,
adamc@759 2578 string "uw_input_",
adamc@759 2579 p_ident x,
adamc@759 2580 string " = result;",
adamc@759 2581 newline],
adamc@759 2582 string "}}",
adamc@759 2583 newline]
adamc@759 2584 end
adamc@756 2585 | _ =>
adamc@756 2586 box [string "request = uw_get_",
adamc@756 2587 string f,
adamc@756 2588 string "input(ctx, ",
adamc@756 2589 string (Int.toString n),
adamc@756 2590 string ");",
adamc@756 2591 newline,
adamc@756 2592 string "if (request == NULL)",
adamc@756 2593 newline,
adamc@756 2594 box [string "uw_error(ctx, FATAL, \"Missing input ",
adamc@756 2595 string x,
adamc@756 2596 string "\");"],
adamc@756 2597 newline,
adamc@756 2598 string "uw_input_",
adamc@756 2599 p_ident x,
adamc@756 2600 space,
adamc@756 2601 string "=",
adamc@756 2602 space,
adamc@1023 2603 unurlify true env t,
adamc@756 2604 string ";",
adamc@756 2605 newline]
adamc@756 2606 end
adamc@756 2607
adamc@1104 2608 fun p_page (ek, s, n, ts, ran, side, tellSig) =
adamc@144 2609 let
adamc@734 2610 val (ts, defInputs, inputsVar, fields) =
adamc@144 2611 case ek of
adam@1347 2612 Core.Action _ =>
adam@1347 2613 (case List.nth (ts, length ts - 2) of
adam@1347 2614 (TRecord i, _) =>
adam@1347 2615 let
adam@1347 2616 val xts = E.lookupStruct env i
adam@1347 2617 in
adam@1347 2618 (List.take (ts, length ts - 2),
adam@1347 2619 box [box (map (fn (x, t) => box [p_typ env t,
adam@1347 2620 space,
adam@1347 2621 string "uw_input_",
adam@1347 2622 p_ident x,
adam@1347 2623 string ";",
adam@1347 2624 newline]) xts),
adam@1347 2625 newline,
adam@1347 2626 box (map getInput xts),
adam@1347 2627 string "struct __uws_",
adam@1347 2628 string (Int.toString i),
adam@1347 2629 space,
adam@1347 2630 string "uw_inputs",
adam@1347 2631 space,
adam@1347 2632 string "= {",
adam@1347 2633 newline,
adam@1347 2634 box (map (fn (x, _) => box [string "uw_input_",
adam@1347 2635 p_ident x,
adam@1347 2636 string ",",
adam@1347 2637 newline]) xts),
adam@1347 2638 string "};",
adam@1347 2639 newline],
adam@1347 2640 box [string ",",
adam@1347 2641 space,
adam@1347 2642 string "uw_inputs"],
adam@1347 2643 SOME xts)
adam@1347 2644 end
adamc@144 2645
adam@1347 2646 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record")
adam@1347 2647 | _ => (List.take (ts, length ts - 1), string "", string "", NONE)
adamc@734 2648
adamc@734 2649 fun couldWrite ek =
adamc@734 2650 case ek of
adamc@734 2651 Link => false
adamc@735 2652 | Action ef => ef = ReadCookieWrite
adamc@735 2653 | Rpc ef => ef = ReadCookieWrite
adam@1384 2654 | Extern _ => false
adamc@863 2655
adamc@863 2656 val s =
adamc@863 2657 case Settings.getUrlPrefix () of
adamc@863 2658 "" => s
adamc@863 2659 | "/" => s
adamc@863 2660 | prefix =>
adamc@863 2661 if size s > 0 andalso String.sub (s, 0) = #"/" then
adamc@863 2662 prefix ^ String.extract (s, 1, NONE)
adamc@863 2663 else
adamc@863 2664 prefix ^ s
adamc@144 2665 in
adamc@735 2666 box [string "if (!strncmp(request, \"",
adam@1285 2667 string (String.toCString s),
adamc@735 2668 string "\", ",
adamc@735 2669 string (Int.toString (size s)),
adamc@735 2670 string ") && (request[",
adamc@735 2671 string (Int.toString (size s)),
adamc@735 2672 string "] == 0 || request[",
adamc@735 2673 string (Int.toString (size s)),
adamc@735 2674 string "] == '/')) {",
adamc@735 2675 newline,
adamc@735 2676 string "request += ",
adamc@735 2677 string (Int.toString (size s)),
adamc@735 2678 string ";",
adamc@735 2679 newline,
adamc@735 2680 string "if (*request == '/') ++request;",
adamc@735 2681 newline,
adamc@735 2682 if couldWrite ek then
adamc@734 2683 box [string "{",
adamc@734 2684 newline,
adamc@734 2685 string "uw_Basis_string sig = ",
adamc@734 2686 case fields of
adamc@734 2687 NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
adamc@734 2688 | SOME fields =>
adamc@734 2689 case SM.find (fnums, sigName fields) of
adamc@734 2690 NONE => raise Fail "CjrPrint: sig name wasn't assigned a number"
adamc@734 2691 | SOME inum =>
adamc@734 2692 string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"),
adamc@734 2693 string ";",
adamc@734 2694 newline,
adamc@734 2695 string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");",
adamc@734 2696 newline,
adamc@734 2697 string "if (strcmp(sig, uw_cookie_sig(ctx)))",
adamc@734 2698 newline,
adamc@734 2699 box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");",
adamc@734 2700 newline],
adamc@734 2701 string "}",
adamc@734 2702 newline]
adamc@734 2703 else
adamc@734 2704 box [],
adamc@609 2705 box (case ek of
adamc@731 2706 Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
adamc@731 2707 newline]
adamc@609 2708 | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");",
adamc@609 2709 newline,
adamc@609 2710 string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
adamc@609 2711 newline,
adamc@804 2712 string "uw_write(ctx, begin_xhtml);",
adamc@643 2713 newline,
adamc@643 2714 string "uw_set_script_header(ctx, \"",
adamc@812 2715 let
adamc@812 2716 val scripts =
adamc@812 2717 case side of
adamc@693 2718 ServerOnly => ""
adamc@1111 2719 | _ =>
adamc@1111 2720 let
adamc@1111 2721 val scripts =
adamc@1111 2722 "<script src=\\\""
adamc@1111 2723 ^ OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
adamc@1111 2724 file = "app.js"}
adamc@1111 2725 ^ "\\\"></script>\\n"
adamc@1111 2726 in
adamc@1111 2727 foldl (fn (x, scripts) =>
adamc@1111 2728 scripts
adamc@1111 2729 ^ "<script src=\\\"" ^ x ^ "\\\"></script>\\n")
adamc@1111 2730 scripts (Settings.getScripts ())
adamc@1111 2731 end
adamc@812 2732 in
adamc@812 2733 string scripts
adamc@812 2734 end,
adamc@643 2735 string "\");",
adamc@609 2736 newline]),
adamc@1038 2737 string "uw_set_needs_push(ctx, ",
adamc@1038 2738 string (case side of
adamc@1038 2739 ServerAndPullAndPush => "1"
adamc@1038 2740 | _ => "0"),
adamc@1038 2741 string ");",
adamc@1038 2742 newline,
adamc@736 2743 string "uw_set_needs_sig(ctx, ",
adamc@1104 2744 string (if tellSig then
adamc@736 2745 "1"
adamc@736 2746 else
adamc@736 2747 "0"),
adamc@736 2748 string ");",
adamc@736 2749 newline,
adamc@682 2750 string "uw_login(ctx);",
adamc@682 2751 newline,
adamc@144 2752 box [string "{",
adamc@144 2753 newline,
adamc@144 2754 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144 2755 space,
adamc@144 2756 string "arg",
adamc@144 2757 string (Int.toString i),
adamc@144 2758 space,
adamc@144 2759 string "=",
adamc@144 2760 space,
adam@1347 2761 case #1 t of
adam@1347 2762 TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)"
adam@1370 2763 | TOption (TFfi ("Basis", "queryString"), _) => string "uw_queryString(ctx)"
adam@1347 2764 | _ => unurlify false env t,
adamc@144 2765 string ";",
adamc@144 2766 newline]) ts),
adamc@144 2767 defInputs,
adamc@609 2768 box (case ek of
adamc@731 2769 Core.Rpc _ => [p_typ env ran,
adamc@731 2770 space,
adamc@731 2771 string "it0",
adamc@731 2772 space,
adamc@731 2773 string "=",
adamc@731 2774 space]
adamc@609 2775 | _ => []),
adamc@144 2776 p_enamed env n,
adamc@144 2777 string "(",
adamc@144 2778 p_list_sep (box [string ",", space])
adamc@144 2779 (fn x => x)
adamc@272 2780 (string "ctx"
adamc@280 2781 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144 2782 inputsVar,
adamc@311 2783 string ", uw_unit_v);",
adamc@144 2784 newline,
adamc@609 2785 box (case ek of
adamc@731 2786 Core.Rpc _ => [urlify env ran]
adamc@609 2787 | _ => [string "uw_write(ctx, \"</html>\");",
adamc@609 2788 newline]),
adamc@144 2789 string "return;",
adamc@144 2790 newline,
adamc@144 2791 string "}",
adamc@144 2792 newline,
adamc@144 2793 string "}"]
adamc@144 2794 ]
adamc@144 2795 end
adamc@144 2796
adamc@144 2797 val pds' = map p_page ps
adamc@275 2798
adamc@870 2799 val hasDb = ref false
adamc@870 2800 val tables = ref []
adamc@872 2801 val views = ref []
adamc@870 2802 val sequences = ref []
adamc@870 2803 val dbstring = ref ""
adamc@870 2804 val expunge = ref 0
adamc@870 2805 val initialize = ref 0
adamc@870 2806 val prepped = ref []
adamc@275 2807
adamc@870 2808 val () = app (fn d =>
adamc@870 2809 case #1 d of
adamc@870 2810 DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
adamc@870 2811 dbstring := x;
adamc@870 2812 expunge := y;
adamc@870 2813 initialize := z)
adamc@870 2814 | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
adamc@870 2815 (x, sql_type_in env t)) xts) :: !tables
adamc@872 2816 | DView (s, xts, _) => views := (s, map (fn (x, t) =>
adamc@872 2817 (x, sql_type_in env t)) xts) :: !views
adamc@870 2818 | DSequence s => sequences := s :: !sequences
adamc@870 2819 | DPreparedStatements ss => prepped := ss
adamc@870 2820 | _ => ()) ds
adamc@377 2821
adam@1381 2822 val hasDb = !hasDb
adam@1381 2823
adam@1381 2824 fun expDb (e, _) =
adam@1381 2825 case e of
adam@1381 2826 ECon (_, _, SOME e) => expDb e
adam@1381 2827 | ESome (_, e) => expDb e
adam@1381 2828 | EFfiApp (_, _, es) => List.exists expDb es
adam@1381 2829 | EApp (e, es) => expDb e orelse List.exists expDb es
adam@1381 2830 | EUnop (_, e) => expDb e
adam@1381 2831 | EBinop (_, e1, e2) => expDb e1 orelse expDb e2
adam@1381 2832 | ERecord (_, xes) => List.exists (expDb o #2) xes
adam@1381 2833 | EField (e, _) => expDb e
adam@1381 2834 | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
adam@1381 2835 | EError (e, _) => expDb e
adam@1381 2836 | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
adam@1381 2837 | ERedirect (e, _) => expDb e
adam@1381 2838 | EWrite e => expDb e
adam@1381 2839 | ESeq (e1, e2) => expDb e1 orelse expDb e2
adam@1381 2840 | ELet (_, _, e1, e2) => expDb e1 orelse expDb e2
adam@1381 2841 | EQuery _ => true
adam@1381 2842 | EDml _ => true
adam@1381 2843 | ENextval _ => true
adam@1381 2844 | ESetval _ => true
adam@1381 2845 | EUnurlify (e, _, _) => expDb e
adam@1381 2846 | _ => false
adam@1381 2847
adam@1381 2848 fun declDb (d, _) =
adam@1381 2849 case d of
adam@1381 2850 DVal (_, _, _, e) => expDb e
adam@1381 2851 | DFun (_, _, _, _, e) => expDb e
adam@1381 2852 | DFunRec vis => List.exists (expDb o #5) vis
adam@1381 2853 | _ => false
adam@1381 2854
adam@1381 2855 val () = if not hasDb andalso List.exists declDb ds then
adam@1381 2856 ErrorMsg.error "Application uses a database but has none configured with 'database' in .urp file."
adam@1381 2857 else
adam@1381 2858 ()
adamc@734 2859
adamc@734 2860 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
adamc@734 2861
adamc@734 2862 val cookieCode = foldl (fn (cookie, acc) =>
adamc@734 2863 SOME (case acc of
adamc@734 2864 NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734 2865 ^ cookie ^ "\"))")
adamc@734 2866 | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734 2867 ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
adamc@734 2868 acc,
adamc@734 2869 string "))"]))
adamc@734 2870 NONE cookies
adamc@770 2871
adamc@770 2872 fun makeChecker (name, rules : Settings.rule list) =
adamc@1094 2873 box [string "static int ",
adamc@770 2874 string name,
adamc@770 2875 string "(const char *s) {",
adamc@770 2876 newline,
adamc@770 2877 box [p_list_sep (box [])
adamc@770 2878 (fn rule =>
adamc@770 2879 box [string "if (!str",
adamc@770 2880 case #kind rule of
adamc@770 2881 Settings.Exact => box [string "cmp(s, \"",
adam@1285 2882 string (String.toCString (#pattern rule)),
adamc@770 2883 string "\"))"]
adamc@770 2884 | Settings.Prefix => box [string "ncmp(s, \"",
adam@1285 2885 string (String.toCString (#pattern rule)),
adamc@770 2886 string "\", ",
adamc@770 2887 string (Int.toString (size (#pattern rule))),
adamc@770 2888 string "))"],
adamc@770 2889 string " return ",
adamc@770 2890 string (case #action rule of
adamc@770 2891 Settings.Allow => "1"
adamc@770 2892 | Settings.Deny => "0"),
adamc@770 2893 string ";",
adamc@770 2894 newline]) rules,
adamc@770 2895 string "return 0;",
adamc@770 2896 newline],
adamc@770 2897 string "}",
adamc@770 2898 newline]
adamc@1073 2899
adam@1348 2900 val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
adam@1348 2901 val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
adam@1349 2902 val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) | _ => NONE) ds
adamc@1263 2903
adam@1294 2904 val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
adam@1294 2905
adamc@1263 2906 val now = Time.now ()
adamc@1263 2907 val nowD = Date.fromTimeUniv now
adamc@1263 2908 val rfcFmt = "%a, %d %b %Y %H:%M:%S"
adamc@29 2909 in
adamc@1263 2910 box [string "#include \"",
adamc@1263 2911 string (OS.Path.joinDirFile {dir = Config.includ,
adamc@1263 2912 file = "config.h"}),
adamc@1263 2913 string "\"",
adamc@1263 2914 newline,
adamc@1263 2915 string "#include <stdio.h>",
adamc@144 2916 newline,
adamc@144 2917 string "#include <stdlib.h>",
adamc@144 2918 newline,
adamc@272 2919 string "#include <string.h>",
adamc@272 2920 newline,
adamc@390 2921 string "#include <math.h>",
adamc@390 2922 newline,
adamc@1263 2923 string "#include <time.h>",
adamc@1263 2924 newline,
adamc@432 2925 if hasDb then
adamc@866 2926 box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
adamc@432 2927 newline]
adamc@432 2928 else
adamc@432 2929 box [],
adamc@764 2930 p_list_sep (box []) (fn s => box [string "#include \"",
adamc@764 2931 string s,
adamc@764 2932 string "\"",
adamc@764 2933 newline]) (Settings.getHeaders ()),
adamc@378 2934 string "#include \"",
adamc@378 2935 string (OS.Path.joinDirFile {dir = Config.includ,
adamc@378 2936 file = "urweb.h"}),
adamc@378 2937 string "\"",
adamc@101 2938 newline,
adamc@101 2939 newline,
adamc@804 2940
adam@1307 2941 box [string "static void uw_setup_limits() {",
adam@1307 2942 newline,
adam@1332 2943 case Settings.getMinHeap () of
adam@1332 2944 0 => box []
adam@1332 2945 | n => box [string "uw_min_heap",
adam@1332 2946 space,
adam@1332 2947 string "=",
adam@1332 2948 space,
adam@1332 2949 string (Int.toString n),
adam@1332 2950 string ";",
adam@1332 2951 newline,
adam@1332 2952 newline],
adam@1307 2953 box [p_list_sep (box []) (fn (class, num) =>
adam@1307 2954 let
adam@1307 2955 val num = case class of
adam@1307 2956 "page" => Int.max (2048, num)
adam@1307 2957 | _ => num
adam@1307 2958 in
adam@1307 2959 box [string ("uw_" ^ class ^ "_max"),
adam@1307 2960 space,
adam@1307 2961 string "=",
adam@1307 2962 space,
adam@1307 2963 string (Int.toString num),
adam@1307 2964 string ";",
adam@1307 2965 newline]
adam@1307 2966 end) (Settings.limits ())],
adam@1307 2967 string "}",
adam@1307 2968 newline,
adam@1307 2969 newline],
adam@1307 2970
adamc@1164 2971 #code (Settings.currentProtocol ()) (),
adamc@1164 2972
adamc@870 2973 if hasDb then
adamc@870 2974 #init (Settings.currentDbms ()) {dbstring = !dbstring,
adamc@870 2975 prepared = !prepped,
adamc@870 2976 tables = !tables,
adamc@872 2977 views = !views,
adamc@870 2978 sequences = !sequences}
adamc@870 2979 else
adam@1307 2980 box [string "static void uw_client_init(void) { };",
adamc@891 2981 newline,
adam@1307 2982 string "static void uw_db_init(uw_context ctx) { };",
adamc@870 2983 newline,
adam@1307 2984 string "static int uw_db_begin(uw_context ctx) { return 0; };",
adamc@870 2985 newline,
adam@1307 2986 string "static void uw_db_close(uw_context ctx) { };",
adamc@1094 2987 newline,
adam@1307 2988 string "static int uw_db_commit(uw_context ctx) { return 0; };",
adamc@870 2989 newline,
adam@1307 2990 string "static int uw_db_rollback(uw_context ctx) { return 0; };"],
adamc@870 2991 newline,
adamc@870 2992 newline,
adamc@870 2993
adam@1407 2994 string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
adam@1407 2995 newline,
adam@1407 2996 newline,
adam@1407 2997
adam@1407 2998 p_list_sep newline (fn x => x) pds,
adam@1407 2999 newline,
adam@1407 3000 newline,
adam@1407 3001 string "static int uw_input_num(const char *name) {",
adam@1407 3002 newline,
adam@1407 3003 makeSwitch (fnums, 0),
adam@1407 3004 string "}",
adam@1407 3005 newline,
adam@1407 3006 newline,
adam@1407 3007
adam@1349 3008 box (ListUtil.mapi (fn (i, (_, x1, x2, e)) =>
adam@1349 3009 box [string "static void uw_periodic",
adam@1349 3010 string (Int.toString i),
adam@1349 3011 string "(uw_context ctx) {",
adam@1349 3012 newline,
adam@1349 3013 box [string "uw_unit __uwr_",
adam@1349 3014 string x1,
adam@1349 3015 string "_0 = uw_unit_v, __uwr_",
adam@1349 3016 string x2,
adam@1349 3017 string "_1 = uw_unit_v;",
adam@1349 3018 newline,
adam@1349 3019 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
adam@1349 3020 string ";",
adam@1349 3021 newline],
adam@1349 3022 string "}",
adam@1349 3023 newline,
adam@1349 3024 newline]) periodics),
adam@1349 3025
adam@1349 3026 string "static uw_periodic my_periodics[] = {",
adam@1349 3027 box (ListUtil.mapi (fn (i, (n, _, _, _)) =>
adam@1349 3028 box [string "{uw_periodic",
adam@1349 3029 string (Int.toString i),
adam@1349 3030 string ",",
adam@1349 3031 space,
adam@1349 3032 string (Int64.toString n),
adam@1349 3033 string "},"]) periodics),
adam@1349 3034 string "{NULL}};",
adam@1349 3035 newline,
adam@1349 3036 newline,
adam@1349 3037
adamc@770 3038 makeChecker ("uw_check_url", Settings.getUrlRules ()),
adamc@770 3039 newline,
adamc@770 3040
adamc@770 3041 makeChecker ("uw_check_mime", Settings.getMimeRules ()),
adamc@770 3042 newline,
adamc@734 3043
adamc@734 3044 string "extern void uw_sign(const char *in, char *out);",
adamc@734 3045 newline,
adamc@734 3046 string "extern int uw_hash_blocksize;",
adamc@734 3047 newline,
adamc@1094 3048 string "static uw_Basis_string uw_cookie_sig(uw_context ctx) {",
adamc@734 3049 newline,
adamc@734 3050 box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);",
adamc@734 3051 newline,
adamc@734 3052 string "uw_sign(",
adamc@734 3053 case cookieCode of
adamc@734 3054 NONE => string "\"\""
adamc@734 3055 | SOME code => code,
adamc@734 3056 string ", r);",
adamc@734 3057 newline,
adamc@734 3058 string "return uw_Basis_makeSigString(ctx, r);",
adamc@734 3059 newline],
adamc@734 3060 string "}",
adamc@734 3061 newline,
adamc@734 3062 newline,
adamc@734 3063
adamc@1094 3064 string "static void uw_handle(uw_context ctx, char *request) {",
adamc@101 3065 newline,
adamc@863 3066 string "if (!strcmp(request, \"",
adamc@863 3067 string (OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
adamc@863 3068 file = "app.js"}),
adamc@863 3069 string "\")) {",
adamc@569 3070 newline,
adamc@1263 3071 box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");",
adamc@1263 3072 newline,
adamc@1263 3073 string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"),
adamc@1263 3074 newline,
adamc@1263 3075 box [string "uw_clear_headers(ctx);",
adamc@1263 3076 newline,
adam@1320 3077 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 3078 newline,
adamc@1263 3079 string "return;",
adamc@1263 3080 newline],
adamc@1263 3081 string "}",
adamc@1263 3082 newline,
adamc@1263 3083 newline,
adamc@1263 3084 string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");",
adamc@1263 3085 newline,
adamc@1263 3086 string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
adamc@569 3087 newline,
adamc@569 3088 string "uw_write(ctx, jslib);",
adamc@569 3089 newline,
adamc@569 3090 string "return;",
adamc@569 3091 newline],
adamc@569 3092 string "}",
adamc@569 3093 newline,
adamc@101 3094 p_list_sep newline (fn x => x) pds',
adamc@101 3095 newline,
adamc@1110 3096 string "uw_clear_headers(ctx);",
adamc@1110 3097 newline,
adamc@1110 3098 string "uw_write_header(ctx, \"HTTP/1.1 404 Not Found\\r\\nContent-type: text/plain\\r\\n\");",
adamc@1110 3099 newline,
adamc@1110 3100 string "uw_write(ctx, \"Not Found\");",
adamc@387 3101 newline,
adamc@101 3102 string "}",
adamc@275 3103 newline,
adamc@275 3104 newline,
adamc@870 3105
adam@1348 3106 box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
adam@1348 3107 newline,
adam@1348 3108
adam@1348 3109 p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
adam@1348 3110 newline,
adam@1348 3111 string "uw_Basis_client __uwr_",
adam@1348 3112 string x1,
adam@1348 3113 string "_0 = cli;",
adam@1348 3114 newline,
adam@1348 3115 string "uw_unit __uwr_",
adam@1348 3116 string x2,
adam@1348 3117 string "_1 = uw_unit_v;",
adam@1348 3118 newline,
adam@1348 3119 p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
adam@1348 3120 x2 dummyt) e,
adam@1348 3121 string ";",
adam@1348 3122 newline,
adam@1348 3123 string "});",
adam@1348 3124 newline]) expungers,
adam@1348 3125
adam@1348 3126 if hasDb then
adamc@870 3127 box [p_enamed env (!expunge),
adamc@870 3128 string "(ctx, cli);",
adam@1348 3129 newline]
adam@1348 3130 else
adam@1348 3131 box [],
adam@1348 3132 string "}"],
adamc@870 3133
adam@1348 3134 newline,
adam@1348 3135 string "static void uw_initializer(uw_context ctx) {",
adam@1348 3136 newline,
adam@1348 3137 box [p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
adam@1348 3138 newline,
adam@1348 3139 string "uw_unit __uwr_",
adam@1348 3140 string x1,
adam@1348 3141 string "_0 = uw_unit_v, __uwr_",
adam@1348 3142 string x2,
adam@1348 3143 string "_1 = uw_unit_v;",
adam@1348 3144 newline,
adam@1348 3145 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
adam@1348 3146 string ";",
adam@1348 3147 newline,
adam@1348 3148 string "});",
adam@1348 3149 newline]) initializers,
adam@1348 3150 if hasDb then
adam@1348 3151 box [p_enamed env (!initialize),
adamc@870 3152 string "(ctx, uw_unit_v);",
adam@1348 3153 newline]
adam@1348 3154 else
adam@1348 3155 box []],
adam@1348 3156 string "}",
adam@1348 3157 newline,
adamc@1094 3158
adam@1294 3159 case onError of
adam@1294 3160 NONE => box []
adam@1294 3161 | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {",
adam@1294 3162 newline,
adam@1294 3163 box [string "uw_write(ctx, ",
adam@1294 3164 p_enamed env n,
adam@1294 3165 string "(ctx, msg, uw_unit_v));",
adam@1294 3166 newline],
adam@1294 3167 string "}",
adam@1294 3168 newline,
adam@1294 3169 newline],
adam@1294 3170
adamc@1094 3171 string "uw_app uw_application = {",
adamc@1094 3172 p_list_sep (box [string ",", newline]) string
adamc@1094 3173 [Int.toString (SM.foldl Int.max 0 fnums + 1),
adamc@1094 3174 Int.toString (Settings.getTimeout ()),
adamc@1094 3175 "\"" ^ Settings.getUrlPrefix () ^ "\"",
adamc@1094 3176 "uw_client_init", "uw_initializer", "uw_expunger",
adamc@1094 3177 "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
adamc@1094 3178 "uw_handle",
adam@1294 3179 "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime",
adam@1349 3180 case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics"],
adamc@1094 3181 string "};",
adamc@1094 3182 newline]
adamc@29 3183 end
adamc@29 3184
adamc@274 3185 fun p_sql env (ds, _) =
adamc@274 3186 let
adamc@274 3187 val (pps, _) = ListUtil.foldlMap
adamc@274 3188 (fn (dAll as (d, _), env) =>
adamc@274 3189 let
adamc@274 3190 val pp = case d of
adamc@707 3191 DTable (s, xts, pk, csts) =>
adamc@274 3192 box [string "CREATE TABLE ",
adamc@274 3193 string s,
adamc@274 3194 string "(",
adamc@274 3195 p_list (fn (x, t) =>
adamc@874 3196 let
adamc@874 3197 val t = sql_type_in env t
adamc@874 3198 in
adamc@874 3199 box [string "uw_",
adamc@874 3200 string (CharVector.map Char.toLower x),
adamc@874 3201 space,
adamc@874 3202 string (#p_sql_type (Settings.currentDbms ()) t),
adamc@874 3203 case t of
adamc@874 3204 Nullable _ => box []
adamc@874 3205 | _ => string " NOT NULL"]
adamc@874 3206 end) xts,
adamc@707 3207 case (pk, csts) of
adamc@707 3208 ("", []) => box []
adamc@707 3209 | _ => string ",",
adamc@704 3210 cut,
adamc@707 3211 case pk of
adamc@707 3212 "" => box []
adamc@707 3213 | _ => box [string "PRIMARY",
adamc@707 3214 space,
adamc@707 3215 string "KEY",
adamc@707 3216 space,
adamc@707 3217 string "(",
adamc@707 3218 string pk,
adamc@707 3219 string ")",
adamc@707 3220 case csts of
adamc@707 3221 [] => box []
adamc@707 3222 | _ => string ",",
adamc@707 3223 newline],
adamc@704 3224 p_list_sep (box [string ",", newline])
adamc@704 3225 (fn (x, c) =>
adamc@704 3226 box [string "CONSTRAINT",
adamc@704 3227 space,
adamc@704 3228 string s,
adamc@704 3229 string "_",
adamc@704 3230 string x,
adamc@704 3231 space,
adamc@704 3232 string c]) csts,
adamc@704 3233 newline,
adamc@274 3234 string ");",
adamc@274 3235 newline,
adamc@274 3236 newline]
adamc@338 3237 | DSequence s =>
adamc@877 3238 box [string (#createSequence (Settings.currentDbms ()) s),
adamc@338 3239 string ";",
adamc@338 3240 newline,
adamc@338 3241 newline]
adamc@754 3242 | DView (s, xts, q) =>
adamc@754 3243 box [string "CREATE VIEW",
adamc@754 3244 space,
adamc@754 3245 string s,
adamc@754 3246 space,
adamc@754 3247 string "AS",
adamc@754 3248 space,
adamc@754 3249 string q,
adamc@754 3250 string ";",
adamc@754 3251 newline,
adamc@754 3252 newline]
adamc@274 3253 | _ => box []
adamc@274 3254 in
adamc@274 3255 (pp, E.declBinds env dAll)
adamc@274 3256 end)
adamc@274 3257 env ds
adamc@274 3258 in
adamc@882 3259 box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
adamc@274 3260 end
adamc@274 3261
adamc@29 3262 end