Mercurial > urweb

annotate src/cjr_print.sml @ 1380:ede95ecb4000

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