Mercurial > urweb

annotate src/cjr_print.sml @ 1496:3010472edf44

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