Mercurial > urweb

annotate src/cjr_print.sml @ 1545:5f530f8e3511

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