Mercurial > urweb

annotate src/cjr_print.sml @ 1542:dc4c61363d0a

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