Mercurial > urweb

annotate src/cjr_print.sml @ 1516:c4f39b49aa2d

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