adamc@643: (* Copyright (c) 2008-2009, Adam Chlipala adamc@29: * All rights reserved. adamc@29: * adamc@29: * Redistribution and use in source and binary forms, with or without adamc@29: * modification, are permitted provided that the following conditions are met: adamc@29: * adamc@29: * - Redistributions of source code must retain the above copyright notice, adamc@29: * this list of conditions and the following disclaimer. adamc@29: * - Redistributions in binary form must reproduce the above copyright notice, adamc@29: * this list of conditions and the following disclaimer in the documentation adamc@29: * and/or other materials provided with the distribution. adamc@29: * - The names of contributors may not be used to endorse or promote products adamc@29: * derived from this software without specific prior written permission. adamc@29: * adamc@29: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@29: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@29: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@29: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@29: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@29: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@29: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@29: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@29: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@29: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@29: * POSSIBILITY OF SUCH DAMAGE. adamc@29: *) adamc@29: adamc@29: (* Pretty-printing C jr. *) adamc@29: adamc@29: structure CjrPrint :> CJR_PRINT = struct adamc@29: adamc@29: open Print.PD adamc@29: open Print adamc@29: adamc@29: open Cjr adamc@29: adamc@269: val dummyt = (TRecord 0, ErrorMsg.dummySpan) adamc@269: adamc@29: structure E = CjrEnv adamc@29: structure EM = ErrorMsg adamc@29: adamc@144: structure SK = struct adamc@144: type ord_key = string adamc@144: val compare = String.compare adamc@144: end adamc@144: adamc@144: structure SS = BinarySetFn(SK) adamc@144: structure SM = BinaryMapFn(SK) adamc@144: structure IS = IntBinarySet adamc@144: adamc@144: structure CM = BinaryMapFn(struct adamc@144: type ord_key = char adamc@144: val compare = Char.compare adamc@144: end) adamc@144: adamc@29: val debug = ref false adamc@29: adamc@196: val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan) adamc@29: adamc@316: val ident = String.translate (fn #"'" => "PRIME" adamc@316: | ch => str ch) adamc@316: adamc@316: val p_ident = string o ident adamc@316: adamc@463: fun isUnboxable (t : typ) = adamc@463: case #1 t of adamc@463: TDatatype (Default, _, _) => true adamc@463: | TFfi ("Basis", "string") => true adamc@463: | _ => false adamc@463: adamc@29: fun p_typ' par env (t, loc) = adamc@29: case t of adamc@476: TFun (t1, t2) => (EM.errorAt loc "Function type remains"; adamc@476: string "") adamc@29: | TRecord i => box [string "struct", adamc@29: space, adamc@311: string "__uws_", adamc@29: string (Int.toString i)] adamc@188: | TDatatype (Enum, n, _) => adamc@188: (box [string "enum", adamc@188: space, adamc@311: string ("__uwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)] adamc@311: handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) adamc@198: | TDatatype (Option, n, xncs) => adamc@198: (case ListUtil.search #3 (!xncs) of adamc@198: NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument" adamc@198: | SOME t => adamc@198: case #1 t of adamc@198: TDatatype _ => p_typ' par env t adamc@199: | TFfi ("Basis", "string") => p_typ' par env t adamc@198: | _ => box [p_typ' par env t, adamc@198: string "*"]) adamc@188: | TDatatype (Default, n, _) => adamc@165: (box [string "struct", adamc@165: space, adamc@311: string ("__uwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] adamc@311: handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) adamc@316: | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] adamc@288: | TOption t => adamc@463: if isUnboxable t then adamc@463: p_typ' par env t adamc@463: else adamc@463: box [p_typ' par env t, adamc@463: string "*"] adamc@29: adamc@29: and p_typ env = p_typ' false env adamc@29: adamc@316: fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) adamc@311: handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) adamc@29: adamc@109: fun p_enamed env n = adamc@316: string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n) adamc@311: handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n) adamc@109: adamc@182: fun p_con_named env n = adamc@316: string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n) adamc@311: handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n) adamc@182: adamc@182: fun p_pat_preamble env (p, _) = adamc@182: case p of adamc@182: PWild => (box [], adamc@182: env) adamc@182: | PVar (x, t) => (box [p_typ env t, adamc@182: space, adamc@311: string "__uwr_", adamc@316: p_ident x, adamc@182: string "_", adamc@182: string (Int.toString (E.countERels env)), adamc@182: string ";", adamc@182: newline], adamc@196: E.pushERel env x t) adamc@182: | PPrim _ => (box [], env) adamc@188: | PCon (_, _, NONE) => (box [], env) adamc@188: | PCon (_, _, SOME p) => p_pat_preamble env p adamc@182: | PRecord xps => adamc@182: foldl (fn ((_, p, _), (pp, env)) => adamc@182: let adamc@182: val (pp', env) = p_pat_preamble env p adamc@182: in adamc@182: (box [pp', pp], env) adamc@182: end) (box [], env) xps adamc@288: | PNone _ => (box [], env) adamc@288: | PSome (_, p) => p_pat_preamble env p adamc@182: adamc@182: fun p_patCon env pc = adamc@182: case pc of adamc@182: PConVar n => p_con_named env n adamc@316: | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con) adamc@182: adamc@182: fun p_pat (env, exit, depth) (p, _) = adamc@182: case p of adamc@182: PWild => adamc@182: (box [], env) adamc@182: | PVar (x, t) => adamc@311: (box [string "__uwr_", adamc@316: p_ident x, adamc@182: string "_", adamc@182: string (Int.toString (E.countERels env)), adamc@182: space, adamc@182: string "=", adamc@182: space, adamc@182: string "disc", adamc@182: string (Int.toString depth), adamc@182: string ";"], adamc@182: E.pushERel env x t) adamc@182: | PPrim (Prim.Int n) => adamc@182: (box [string "if", adamc@182: space, adamc@182: string "(disc", adamc@182: string (Int.toString depth), adamc@182: space, adamc@182: string "!=", adamc@182: space, adamc@276: Prim.p_t_GCC (Prim.Int n), adamc@182: string ")", adamc@182: space, adamc@182: exit], adamc@182: env) adamc@182: | PPrim (Prim.String s) => adamc@182: (box [string "if", adamc@182: space, adamc@182: string "(strcmp(disc", adamc@182: string (Int.toString depth), adamc@182: string ",", adamc@182: space, adamc@276: Prim.p_t_GCC (Prim.String s), adamc@182: string "))", adamc@182: space, adamc@182: exit], adamc@182: env) adamc@182: | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive" adamc@182: adamc@188: | PCon (dk, pc, po) => adamc@182: let adamc@182: val (p, env) = adamc@182: case po of adamc@182: NONE => (box [], env) adamc@182: | SOME p => adamc@182: let adamc@182: val (p, env) = p_pat (env, exit, depth + 1) p adamc@182: adamc@182: val (x, to) = case pc of adamc@182: PConVar n => adamc@182: let adamc@182: val (x, to, _) = E.lookupConstructor env n adamc@182: in adamc@316: ("uw_" ^ ident x, to) adamc@182: end adamc@188: | PConFfi {mod = m, con, arg, ...} => adamc@316: ("uw_" ^ ident m ^ "_" ^ ident con, arg) adamc@182: adamc@182: val t = case to of adamc@182: NONE => raise Fail "CjrPrint: Constructor mismatch" adamc@182: | SOME t => t adamc@182: in adamc@182: (box [string "{", adamc@182: newline, adamc@182: p_typ env t, adamc@182: space, adamc@182: string "disc", adamc@182: string (Int.toString (depth + 1)), adamc@182: space, adamc@182: string "=", adamc@182: space, adamc@198: case dk of adamc@198: Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" adamc@198: | Default => box [string "disc", adamc@198: string (Int.toString depth), adamc@198: string "->data.", adamc@198: string x] adamc@198: | Option => adamc@463: if isUnboxable t then adamc@463: box [string "disc", adamc@463: string (Int.toString depth)] adamc@463: else adamc@463: box [string "*disc", adamc@463: string (Int.toString depth)], adamc@182: string ";", adamc@182: newline, adamc@182: p, adamc@182: newline, adamc@182: string "}"], adamc@182: env) adamc@182: end adamc@182: in adamc@182: (box [string "if", adamc@182: space, adamc@182: string "(disc", adamc@182: string (Int.toString depth), adamc@198: case (dk, po) of adamc@198: (Enum, _) => box [space, adamc@198: string "!=", adamc@198: space, adamc@198: p_patCon env pc] adamc@198: | (Default, _) => box [string "->tag", adamc@198: space, adamc@198: string "!=", adamc@198: space, adamc@198: p_patCon env pc] adamc@198: | (Option, NONE) => box [space, adamc@198: string "!=", adamc@198: space, adamc@198: string "NULL"] adamc@198: | (Option, SOME _) => box [space, adamc@198: string "==", adamc@198: space, adamc@198: string "NULL"], adamc@182: string ")", adamc@182: space, adamc@182: exit, adamc@182: newline, adamc@182: p], adamc@182: env) adamc@182: end adamc@182: adamc@182: | PRecord xps => adamc@182: let adamc@182: val (xps, env) = adamc@182: ListUtil.foldlMap (fn ((x, p, t), env) => adamc@182: let adamc@182: val (p, env) = p_pat (env, exit, depth + 1) p adamc@182: adamc@182: val p = box [string "{", adamc@182: newline, adamc@182: p_typ env t, adamc@182: space, adamc@182: string "disc", adamc@182: string (Int.toString (depth + 1)), adamc@182: space, adamc@182: string "=", adamc@182: space, adamc@182: string "disc", adamc@182: string (Int.toString depth), adamc@311: string ".__uwf_", adamc@316: p_ident x, adamc@182: string ";", adamc@182: newline, adamc@182: p, adamc@182: newline, adamc@182: string "}"] adamc@182: in adamc@182: (p, env) adamc@182: end) env xps adamc@182: in adamc@182: (p_list_sep newline (fn x => x) xps, adamc@182: env) adamc@182: end adamc@182: adamc@288: | PNone t => adamc@288: (box [string "if", adamc@288: space, adamc@288: string "(disc", adamc@288: string (Int.toString depth), adamc@288: space, adamc@288: string "!=", adamc@288: space, adamc@288: string "NULL)", adamc@288: space, adamc@288: exit, adamc@288: newline], adamc@288: env) adamc@288: adamc@288: | PSome (t, p) => adamc@288: let adamc@288: val (p, env) = adamc@288: let adamc@288: val (p, env) = p_pat (env, exit, depth + 1) p adamc@288: in adamc@288: (box [string "{", adamc@288: newline, adamc@288: p_typ env t, adamc@288: space, adamc@288: string "disc", adamc@288: string (Int.toString (depth + 1)), adamc@288: space, adamc@288: string "=", adamc@288: space, adamc@463: if isUnboxable t then adamc@463: box [string "disc", adamc@463: string (Int.toString depth)] adamc@463: else adamc@463: box [string "*disc", adamc@463: string (Int.toString depth)], adamc@288: string ";", adamc@288: newline, adamc@288: p, adamc@288: newline, adamc@288: string "}"], adamc@288: env) adamc@288: end adamc@288: in adamc@288: (box [string "if", adamc@288: space, adamc@288: string "(disc", adamc@288: string (Int.toString depth), adamc@288: space, adamc@288: string "==", adamc@288: space, adamc@288: string "NULL)", adamc@288: space, adamc@288: exit, adamc@288: newline, adamc@288: p], adamc@288: env) adamc@288: end adamc@288: adamc@182: local adamc@182: val count = ref 0 adamc@182: in adamc@182: fun newGoto () = adamc@182: let adamc@182: val r = !count adamc@182: in adamc@182: count := r + 1; adamc@182: string ("L" ^ Int.toString r) adamc@182: end adamc@182: end adamc@182: adamc@185: fun patConInfo env pc = adamc@185: case pc of adamc@185: PConVar n => adamc@185: let adamc@185: val (x, _, dn) = E.lookupConstructor env n adamc@185: val (dx, _) = E.lookupDatatype env dn adamc@185: in adamc@316: ("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn, adamc@316: "__uwc_" ^ ident x ^ "_" ^ Int.toString n, adamc@316: "uw_" ^ ident x) adamc@185: end adamc@186: | PConFfi {mod = m, datatyp, con, ...} => adamc@316: ("uw_" ^ ident m ^ "_" ^ ident datatyp, adamc@316: "uw_" ^ ident m ^ "_" ^ ident con, adamc@316: "uw_" ^ ident con) adamc@185: adamc@324: fun p_unsql wontLeakStrings env (tAll as (t, loc)) e = adamc@278: case t of adamc@311: TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"] adamc@311: | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"] adamc@324: | TFfi ("Basis", "string") => adamc@324: if wontLeakStrings then adamc@324: e adamc@324: else adamc@324: box [string "uw_Basis_strdup(ctx, ", e, string ")"] adamc@311: | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] adamc@438: | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] adamc@678: | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] adamc@682: | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"] adamc@467: adamc@278: | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; adamc@278: Print.eprefaces' [("Type", p_typ env tAll)]; adamc@278: string "ERROR") adamc@278: adamc@467: fun p_getcol wontLeakStrings env (tAll as (t, loc)) i = adamc@467: case t of adamc@467: TOption t => adamc@467: box [string "(PQgetisnull (res, i, ", adamc@467: string (Int.toString i), adamc@467: string ") ? NULL : ", adamc@467: case t of adamc@467: (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i adamc@467: | _ => box [string "({", adamc@467: newline, adamc@467: p_typ env t, adamc@467: space, adamc@467: string "*tmp = uw_malloc(ctx, sizeof(", adamc@467: p_typ env t, adamc@467: string "));", adamc@467: newline, adamc@467: string "*tmp = ", adamc@467: p_getcol wontLeakStrings env t i, adamc@467: string ";", adamc@467: newline, adamc@467: string "tmp;", adamc@467: newline, adamc@467: string "})"], adamc@467: string ")"] adamc@467: adamc@467: | _ => adamc@467: p_unsql wontLeakStrings env tAll adamc@467: (box [string "PQgetvalue(res, i, ", adamc@467: string (Int.toString i), adamc@467: string ")"]) adamc@467: adamc@282: datatype sql_type = adamc@282: Int adamc@282: | Float adamc@282: | String adamc@282: | Bool adamc@439: | Time adamc@678: | Channel adamc@682: | Client adamc@467: | Nullable of sql_type adamc@282: adamc@467: fun p_sql_type' t = adamc@467: case t of adamc@467: Int => "uw_Basis_int" adamc@467: | Float => "uw_Basis_float" adamc@467: | String => "uw_Basis_string" adamc@467: | Bool => "uw_Basis_bool" adamc@467: | Time => "uw_Basis_time" adamc@678: | Channel => "uw_Basis_channel" adamc@682: | Client => "uw_Basis_client" adamc@467: | Nullable String => "uw_Basis_string" adamc@467: | Nullable t => p_sql_type' t ^ "*" adamc@467: adamc@467: fun p_sql_type t = string (p_sql_type' t) adamc@282: adamc@282: fun getPargs (e, _) = adamc@282: case e of adamc@282: EPrim (Prim.String _) => [] adamc@282: | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2 adamc@282: adamc@282: | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)] adamc@282: | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)] adamc@282: | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] adamc@282: | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] adamc@439: | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] adamc@678: | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)] adamc@682: | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)] adamc@468: adamc@678: | ECase (e, adamc@678: [((PNone _, _), adamc@678: (EPrim (Prim.String "NULL"), _)), adamc@678: ((PSome (_, (PVar _, _)), _), adamc@678: (EFfiApp (m, x, [(ERel 0, _)]), _))], adamc@678: _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e)) adamc@468: adamc@491: | ECase (e, adamc@491: [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), adamc@491: (EPrim (Prim.String "TRUE"), _)), adamc@491: ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), adamc@491: (EPrim (Prim.String "FALSE"), _))], adamc@491: _) => [(e, Bool)] adamc@282: adamc@282: | _ => raise Fail "CjrPrint: getPargs" adamc@282: adamc@282: fun p_ensql t e = adamc@282: case t of adamc@311: Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"] adamc@311: | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] adamc@282: | String => e adamc@295: | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] adamc@682: | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"] adamc@678: | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"] adamc@682: | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"] adamc@467: | Nullable String => e adamc@467: | Nullable t => box [string "(", adamc@467: e, adamc@467: string " == NULL ? NULL : ", adamc@467: p_ensql t (box [string "*", e]), adamc@467: string ")"] adamc@282: adamc@324: fun notLeaky env allowHeapAllocated = adamc@324: let adamc@638: fun nl ok (t, _) = adamc@324: case t of adamc@324: TFun _ => false adamc@324: | TRecord n => adamc@324: let adamc@324: val xts = E.lookupStruct env n adamc@324: in adamc@638: List.all (fn (_, t) => nl ok t) xts adamc@324: end adamc@638: | TDatatype (dk, n, ref cons) => adamc@638: IS.member (ok, n) adamc@638: orelse adamc@638: ((allowHeapAllocated orelse dk = Enum) adamc@638: andalso adamc@638: let adamc@638: val ok' = IS.add (ok, n) adamc@638: in adamc@638: List.all (fn (_, _, to) => case to of adamc@638: NONE => true adamc@638: | SOME t => nl ok' t) cons adamc@638: end) adamc@324: | TFfi ("Basis", "string") => false adamc@324: | TFfi _ => true adamc@638: | TOption t => allowHeapAllocated andalso nl ok t adamc@324: in adamc@638: nl IS.empty adamc@324: end adamc@324: adamc@463: fun capitalize s = adamc@463: if s = "" then adamc@463: "" adamc@463: else adamc@463: str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@463: adamc@463: fun unurlify env (t, loc) = adamc@463: let adamc@463: fun unurlify' rf t = adamc@463: case t of adamc@463: TFfi ("Basis", "unit") => string ("uw_unit_v") adamc@463: | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") adamc@463: adamc@463: | TRecord 0 => string "uw_unit_v" adamc@463: | TRecord i => adamc@463: let adamc@463: val xts = E.lookupStruct env i adamc@463: in adamc@463: box [string "({", adamc@463: newline, adamc@463: box (map (fn (x, t) => adamc@463: box [p_typ env t, adamc@463: space, adamc@463: string "uwr_", adamc@463: string x, adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: unurlify' rf (#1 t), adamc@463: string ";", adamc@463: newline]) xts), adamc@463: string "struct", adamc@463: space, adamc@463: string "__uws_", adamc@463: string (Int.toString i), adamc@463: space, adamc@463: string "tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string "{", adamc@463: space, adamc@463: p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", adamc@463: string x]) xts, adamc@463: space, adamc@463: string "};", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@463: end adamc@463: adamc@463: | TDatatype (Enum, i, _) => adamc@463: let adamc@463: val (x, xncs) = E.lookupDatatype env i adamc@463: adamc@463: fun doEm xncs = adamc@463: case xncs of adamc@463: [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " adamc@463: ^ x ^ "\"), (enum __uwe_" adamc@463: ^ x ^ "_" ^ Int.toString i ^ ")0)") adamc@463: | (x', n, to) :: rest => adamc@463: box [string "((!strncmp(request, \"", adamc@463: string x', adamc@463: string "\", ", adamc@463: string (Int.toString (size x')), adamc@463: string ") && (request[", adamc@463: string (Int.toString (size x')), adamc@463: string "] == 0 || request[", adamc@463: string (Int.toString (size x')), adamc@463: string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), adamc@463: space, adamc@463: string ":", adamc@463: space, adamc@463: doEm rest, adamc@463: string ")"] adamc@463: in adamc@463: doEm xncs adamc@463: end adamc@463: adamc@463: | TDatatype (Option, i, xncs) => adamc@463: if IS.member (rf, i) then adamc@463: box [string "unurlify_", adamc@463: string (Int.toString i), adamc@463: string "()"] adamc@463: else adamc@463: let adamc@463: val (x, _) = E.lookupDatatype env i adamc@463: adamc@463: val (no_arg, has_arg, t) = adamc@463: case !xncs of adamc@463: [(no_arg, _, NONE), (has_arg, _, SOME t)] => adamc@463: (no_arg, has_arg, t) adamc@463: | [(has_arg, _, SOME t), (no_arg, _, NONE)] => adamc@463: (no_arg, has_arg, t) adamc@463: | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" adamc@463: adamc@463: val rf = IS.add (rf, i) adamc@463: in adamc@463: box [string "({", adamc@463: space, adamc@463: p_typ env t, adamc@463: space, adamc@463: string "*unurlify_", adamc@463: string (Int.toString i), adamc@463: string "(void) {", adamc@463: newline, adamc@463: box [string "return (request[0] == '/' ? ++request : request,", adamc@463: newline, adamc@463: string "((!strncmp(request, \"", adamc@463: string no_arg, adamc@463: string "\", ", adamc@463: string (Int.toString (size no_arg)), adamc@463: string ") && (request[", adamc@463: string (Int.toString (size no_arg)), adamc@463: string "] == 0 || request[", adamc@463: string (Int.toString (size no_arg)), adamc@463: string "] == '/')) ? (request", adamc@463: space, adamc@463: string "+=", adamc@463: space, adamc@463: string (Int.toString (size no_arg)), adamc@463: string ", NULL) : ((!strncmp(request, \"", adamc@463: string has_arg, adamc@463: string "\", ", adamc@463: string (Int.toString (size has_arg)), adamc@463: string ") && (request[", adamc@463: string (Int.toString (size has_arg)), adamc@463: string "] == 0 || request[", adamc@463: string (Int.toString (size has_arg)), adamc@463: string "] == '/')) ? (request", adamc@463: space, adamc@463: string "+=", adamc@463: space, adamc@463: string (Int.toString (size has_arg)), adamc@463: string ", (request[0] == '/' ? ++request : NULL), ", adamc@463: newline, adamc@463: adamc@463: if isUnboxable t then adamc@463: unurlify' rf (#1 t) adamc@463: else adamc@463: box [string "({", adamc@463: newline, adamc@463: p_typ env t, adamc@463: space, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string "uw_malloc(ctx, sizeof(", adamc@463: p_typ env t, adamc@463: string "));", adamc@463: newline, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: unurlify' rf (#1 t), adamc@463: string ";", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"], adamc@463: string ")", adamc@463: newline, adamc@463: string ":", adamc@463: space, adamc@463: string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x adamc@463: ^ "\"), NULL))));"), adamc@463: newline], adamc@463: string "}", adamc@463: newline, adamc@463: newline, adamc@463: adamc@463: string "unurlify_", adamc@463: string (Int.toString i), adamc@463: string "();", adamc@463: newline, adamc@463: string "})"] adamc@463: end adamc@463: adamc@463: | TDatatype (Default, i, _) => adamc@463: if IS.member (rf, i) then adamc@463: box [string "unurlify_", adamc@463: string (Int.toString i), adamc@463: string "()"] adamc@463: else adamc@463: let adamc@463: val (x, xncs) = E.lookupDatatype env i adamc@463: adamc@463: val rf = IS.add (rf, i) adamc@463: adamc@463: fun doEm xncs = adamc@463: case xncs of adamc@463: [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " adamc@463: ^ x ^ "\"), NULL)") adamc@463: | (x', n, to) :: rest => adamc@463: box [string "((!strncmp(request, \"", adamc@463: string x', adamc@463: string "\", ", adamc@463: string (Int.toString (size x')), adamc@463: string ") && (request[", adamc@463: string (Int.toString (size x')), adamc@463: string "] == 0 || request[", adamc@463: string (Int.toString (size x')), adamc@463: string "] == '/')) ? ({", adamc@463: newline, adamc@463: string "struct", adamc@463: space, adamc@463: string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), adamc@463: space, adamc@463: string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", adamc@463: string x, adamc@463: string "_", adamc@463: string (Int.toString i), adamc@463: string "));", adamc@463: newline, adamc@463: string "tmp->tag", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), adamc@463: string ";", adamc@463: newline, adamc@463: string "request", adamc@463: space, adamc@463: string "+=", adamc@463: space, adamc@463: string (Int.toString (size x')), adamc@463: string ";", adamc@463: newline, adamc@463: string "if (request[0] == '/') ++request;", adamc@463: newline, adamc@463: case to of adamc@463: NONE => box [] adamc@463: | SOME (t, _) => box [string "tmp->data.uw_", adamc@463: p_ident x', adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: unurlify' rf t, adamc@463: string ";", adamc@463: newline], adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})", adamc@463: space, adamc@463: string ":", adamc@463: space, adamc@463: doEm rest, adamc@463: string ")"] adamc@463: in adamc@463: box [string "({", adamc@463: space, adamc@463: p_typ env (t, ErrorMsg.dummySpan), adamc@463: space, adamc@463: string "unurlify_", adamc@463: string (Int.toString i), adamc@463: string "(void) {", adamc@463: newline, adamc@463: box [string "return", adamc@463: space, adamc@463: doEm xncs, adamc@463: string ";", adamc@463: newline], adamc@463: string "}", adamc@463: newline, adamc@463: newline, adamc@463: adamc@463: string "unurlify_", adamc@463: string (Int.toString i), adamc@463: string "();", adamc@463: newline, adamc@463: string "})"] adamc@463: end adamc@463: adamc@471: | TOption t => adamc@471: box [string "(request[0] == '/' ? ++request : request, ", adamc@471: string "((!strncmp(request, \"None\", 4) ", adamc@471: string "&& (request[4] == 0 || request[4] == '/')) ", adamc@471: string "? (request += 4, NULL) ", adamc@471: string ": ((!strncmp(request, \"Some\", 4) ", adamc@471: string "&& request[4] == '/') ", adamc@471: string "? (request += 5, ", adamc@471: if isUnboxable t then adamc@471: unurlify' rf (#1 t) adamc@471: else adamc@471: box [string "({", adamc@471: newline, adamc@471: p_typ env t, adamc@471: space, adamc@471: string "*tmp", adamc@471: space, adamc@471: string "=", adamc@471: space, adamc@471: string "uw_malloc(ctx, sizeof(", adamc@471: p_typ env t, adamc@471: string "));", adamc@471: newline, adamc@471: string "*tmp", adamc@471: space, adamc@471: string "=", adamc@471: space, adamc@471: unurlify' rf (#1 t), adamc@471: string ";", adamc@471: newline, adamc@471: string "tmp;", adamc@471: newline, adamc@471: string "})"], adamc@471: string ") :", adamc@471: space, adamc@471: string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"] adamc@471: adamc@463: | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; adamc@463: space) adamc@463: in adamc@463: unurlify' IS.empty t adamc@463: end adamc@463: adamc@610: fun urlify env t = adamc@610: let adamc@610: fun urlify' rf level (t as (_, loc)) = adamc@610: case #1 t of adamc@610: TFfi ("Basis", "unit") => box [] adamc@610: | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t adamc@610: ^ "_w(ctx, it" ^ Int.toString level ^ ");"), adamc@610: newline] adamc@610: adamc@610: | TRecord 0 => box [] adamc@610: | TRecord i => adamc@610: let adamc@611: fun empty (t, _) = adamc@611: case t of adamc@611: TFfi ("Basis", "unit") => true adamc@611: | TRecord 0 => true adamc@611: | TRecord j => adamc@611: List.all (fn (_, t) => empty t) (E.lookupStruct env j) adamc@611: | _ => false adamc@611: adamc@610: val xts = E.lookupStruct env i adamc@611: adamc@613: val (blocks, _) = foldl adamc@613: (fn ((x, t), (blocks, printingSinceLastSlash)) => adamc@613: let adamc@613: val thisEmpty = empty t adamc@613: in adamc@613: if thisEmpty then adamc@613: (blocks, printingSinceLastSlash) adamc@613: else adamc@613: (box [string "{", adamc@613: newline, adamc@613: p_typ env t, adamc@613: space, adamc@613: string ("it" ^ Int.toString (level + 1)), adamc@613: space, adamc@613: string "=", adamc@613: space, adamc@613: string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), adamc@613: newline, adamc@613: box (if printingSinceLastSlash then adamc@613: [string "uw_write(ctx, \"/\");", adamc@613: newline] adamc@613: else adamc@613: []), adamc@613: urlify' rf (level + 1) t, adamc@613: string "}", adamc@613: newline] :: blocks, adamc@613: true) adamc@613: end) adamc@613: ([], false) xts adamc@610: in adamc@613: box (rev blocks) adamc@610: end adamc@610: adamc@638: | TDatatype (Enum, i, _) => adamc@638: let adamc@610: val (x, xncs) = E.lookupDatatype env i adamc@610: adamc@610: fun doEm xncs = adamc@610: case xncs of adamc@638: [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " adamc@638: ^ x ^ "\");"), adamc@638: newline] adamc@610: | (x', n, to) :: rest => adamc@638: box [string ("if (it" ^ Int.toString level adamc@638: ^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"), adamc@638: newline, adamc@638: box [string ("uw_write(ctx, \"" ^ x' ^ "\");"), adamc@638: newline], adamc@638: string "} else {", adamc@638: newline, adamc@638: box [doEm rest, adamc@638: newline], adamc@638: string "}"] adamc@610: in adamc@610: doEm xncs adamc@638: end adamc@610: adamc@639: | TDatatype (Option, i, xncs) => adamc@639: if IS.member (rf, i) then adamc@639: box [string "urlify_", adamc@610: string (Int.toString i), adamc@639: string "(it", adamc@639: string (Int.toString level), adamc@639: string ");", adamc@639: newline] adamc@610: else adamc@610: let adamc@610: val (x, _) = E.lookupDatatype env i adamc@610: adamc@610: val (no_arg, has_arg, t) = adamc@610: case !xncs of adamc@610: [(no_arg, _, NONE), (has_arg, _, SOME t)] => adamc@610: (no_arg, has_arg, t) adamc@610: | [(has_arg, _, SOME t), (no_arg, _, NONE)] => adamc@610: (no_arg, has_arg, t) adamc@639: | _ => raise Fail "CjrPrint: urlify misclassified Option datatype" adamc@610: adamc@610: val rf = IS.add (rf, i) adamc@610: in adamc@610: box [string "({", adamc@610: space, adamc@639: string "void", adamc@639: space, adamc@639: string "urlify_", adamc@639: string (Int.toString i), adamc@639: string "(", adamc@610: p_typ env t, adamc@610: space, adamc@639: if isUnboxable t then adamc@639: box [] adamc@639: else adamc@639: string "*", adamc@639: string "it0) {", adamc@610: newline, adamc@639: box [string "if (it0) {", adamc@639: if isUnboxable t then adamc@639: urlify' rf 0 t adamc@610: else adamc@639: box [p_typ env t, adamc@610: space, adamc@639: string "it1", adamc@610: space, adamc@610: string "=", adamc@610: space, adamc@639: string "*it0;", adamc@610: newline, adamc@639: string "uw_write(ctx, \"", adamc@639: string has_arg, adamc@639: string "/\");", adamc@639: newline, adamc@639: urlify' rf 1 t, adamc@610: string ";", adamc@639: newline], adamc@639: string "} else {", adamc@639: box [string "uw_write(ctx, \"", adamc@639: string no_arg, adamc@639: string "\");", adamc@639: newline], adamc@639: string "}", adamc@610: newline], adamc@610: string "}", adamc@610: newline, adamc@610: newline, adamc@610: adamc@639: string "urlify_", adamc@610: string (Int.toString i), adamc@639: string "(it", adamc@639: string (Int.toString level), adamc@639: string ");", adamc@610: newline, adamc@639: string "});", adamc@639: newline] adamc@639: end adamc@610: adamc@640: | TDatatype (Default, i, _) => adamc@640: if IS.member (rf, i) then adamc@640: box [string "urlify_", adamc@610: string (Int.toString i), adamc@640: string "(it", adamc@640: string (Int.toString level), adamc@640: string ");", adamc@640: newline] adamc@610: else adamc@610: let adamc@610: val (x, xncs) = E.lookupDatatype env i adamc@610: adamc@610: val rf = IS.add (rf, i) adamc@610: adamc@610: fun doEm xncs = adamc@610: case xncs of adamc@640: [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " adamc@640: ^ x ^ " (%d)\", it0->data);"), adamc@640: newline] adamc@610: | (x', n, to) :: rest => adamc@640: box [string "if", adamc@610: space, adamc@640: string "(it0->tag==__uwc_", adamc@640: string (ident x'), adamc@610: string "_", adamc@640: string (Int.toString n), adamc@640: string ") {", adamc@610: newline, adamc@610: case to of adamc@640: NONE => box [string "uw_write(ctx, \"", adamc@640: string x', adamc@640: string "\");", adamc@640: newline] adamc@640: | SOME t => box [string "uw_write(ctx, \"", adamc@640: string x', adamc@640: string "/\");", adamc@640: newline, adamc@640: p_typ env t, adamc@640: space, adamc@640: string "it1", adamc@640: space, adamc@640: string "=", adamc@640: space, adamc@640: string "it0->data.uw_", adamc@640: string x', adamc@640: string ";", adamc@640: newline, adamc@640: urlify' rf 1 t, adamc@640: newline], adamc@640: string "} else {", adamc@610: newline, adamc@640: box [doEm rest, adamc@640: newline], adamc@640: string "}", adamc@640: newline] adamc@610: in adamc@610: box [string "({", adamc@610: space, adamc@640: string "void", adamc@610: space, adamc@640: string "urlify_", adamc@610: string (Int.toString i), adamc@640: string "(", adamc@640: p_typ env t, adamc@640: space, adamc@640: string "it0) {", adamc@610: newline, adamc@640: box [doEm xncs, adamc@610: newline], adamc@640: newline, adamc@610: string "}", adamc@610: newline, adamc@640: adamc@640: string "urlify_", adamc@640: string (Int.toString i), adamc@640: string "(it", adamc@640: string (Int.toString level), adamc@640: string ");", adamc@610: newline, adamc@640: string "});", adamc@640: newline] adamc@640: end adamc@610: adamc@641: | TOption t => adamc@641: box [string "if (it", adamc@641: string (Int.toString level), adamc@641: string ") {", adamc@641: if isUnboxable t then adamc@641: box [string "uw_write(ctx, \"Some/\");", adamc@641: newline, adamc@641: urlify' rf level t] adamc@610: else adamc@641: box [p_typ env t, adamc@610: space, adamc@641: string "it", adamc@641: string (Int.toString (level + 1)), adamc@610: space, adamc@610: string "=", adamc@610: space, adamc@641: string "*it", adamc@641: string (Int.toString level), adamc@610: string ";", adamc@610: newline, adamc@641: string "uw_write(ctx, \"Some/\");", adamc@610: newline, adamc@641: urlify' rf (level + 1) t, adamc@641: string ";", adamc@641: newline], adamc@641: string "} else {", adamc@641: box [string "uw_write(ctx, \"None\");", adamc@641: newline], adamc@641: string "}", adamc@641: newline] adamc@610: adamc@610: | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; adamc@610: space) adamc@610: in adamc@610: urlify' IS.empty 0 t adamc@610: end adamc@610: adamc@673: val timeout = ref 0 adamc@673: adamc@182: fun p_exp' par env (e, loc) = adamc@29: case e of adamc@276: EPrim p => Prim.p_t_GCC p adamc@29: | ERel n => p_rel env n adamc@109: | ENamed n => p_enamed env n adamc@188: | ECon (Enum, pc, _) => p_patCon env pc adamc@198: | ECon (Option, pc, NONE) => string "NULL" adamc@198: | ECon (Option, pc, SOME e) => adamc@198: let adamc@198: val to = case pc of adamc@198: PConVar n => #2 (E.lookupConstructor env n) adamc@198: | PConFfi {arg, ...} => arg adamc@198: adamc@198: val t = case to of adamc@198: NONE => raise Fail "CjrPrint: ECon argument status mismatch" adamc@198: | SOME t => t adamc@198: in adamc@463: if isUnboxable t then adamc@463: p_exp' par env e adamc@463: else adamc@463: box [string "({", adamc@463: newline, adamc@463: p_typ env t, adamc@463: space, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string "uw_malloc(ctx, sizeof(", adamc@463: p_typ env t, adamc@463: string "));", adamc@463: newline, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: p_exp' par env e, adamc@463: string ";", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@198: end adamc@188: | ECon (Default, pc, eo) => adamc@181: let adamc@196: val (xd, xc, xn) = patConInfo env pc adamc@181: in adamc@182: box [string "({", adamc@181: newline, adamc@181: string "struct", adamc@181: space, adamc@185: string xd, adamc@181: space, adamc@181: string "*tmp", adamc@181: space, adamc@181: string "=", adamc@181: space, adamc@311: string "uw_malloc(ctx, sizeof(struct ", adamc@185: string xd, adamc@181: string "));", adamc@181: newline, adamc@181: string "tmp->tag", adamc@181: space, adamc@181: string "=", adamc@181: space, adamc@185: string xc, adamc@181: string ";", adamc@181: newline, adamc@181: case eo of adamc@181: NONE => box [] adamc@185: | SOME e => box [string "tmp->data.", adamc@196: string xn, adamc@181: space, adamc@181: string "=", adamc@181: space, adamc@181: p_exp env e, adamc@181: string ";", adamc@181: newline], adamc@181: string "tmp;", adamc@181: newline, adamc@181: string "})"] adamc@181: end adamc@297: | ENone _ => string "NULL" adamc@290: | ESome (t, e) => adamc@463: if isUnboxable t then adamc@463: p_exp' par env e adamc@463: else adamc@463: box [string "({", adamc@463: newline, adamc@463: p_typ env t, adamc@463: space, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: space, adamc@463: string "uw_malloc(ctx, sizeof(", adamc@463: p_typ env t, adamc@463: string "));", adamc@463: newline, adamc@463: string "*tmp", adamc@463: space, adamc@463: string "=", adamc@463: p_exp' par env e, adamc@463: string ";", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@109: adamc@316: | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] adamc@283: | EError (e, t) => adamc@283: box [string "({", adamc@283: newline, adamc@283: p_typ env t, adamc@283: space, adamc@283: string "tmp;", adamc@283: newline, adamc@311: string "uw_error(ctx, FATAL, \"", adamc@292: string (ErrorMsg.spanToString loc), adamc@292: string ": %s\", ", adamc@283: p_exp env e, adamc@283: string ");", adamc@283: newline, adamc@283: string "tmp;", adamc@283: newline, adamc@283: string "})"] adamc@476: | EApp ((EError (e, (TFun (_, ran), _)), loc), _) => adamc@476: p_exp env (EError (e, ran), loc) adamc@476: adamc@311: | EFfiApp (m, x, es) => box [string "uw_", adamc@316: p_ident m, adamc@53: string "_", adamc@316: p_ident x, adamc@117: string "(ctx, ", adamc@53: p_list (p_exp env) es, adamc@53: string ")"] adamc@316: | EApp (f, args) => adamc@316: parenIf par (box [p_exp' true env f, adamc@316: string "(ctx,", adamc@316: space, adamc@316: p_list_sep (box [string ",", space]) (p_exp env) args, adamc@316: string ")"]) adamc@29: adamc@387: | EUnop (s, e1) => adamc@387: parenIf par (box [string s, adamc@387: space, adamc@387: p_exp' true env e1]) adamc@387: adamc@387: | EBinop (s, e1, e2) => adamc@389: if Char.isAlpha (String.sub (s, size s - 1)) then adamc@389: box [string s, adamc@390: string "(", adamc@389: p_exp env e1, adamc@389: string ",", adamc@389: space, adamc@389: p_exp env e2, adamc@389: string ")"] adamc@389: else adamc@389: parenIf par (box [p_exp' true env e1, adamc@389: space, adamc@389: string s, adamc@389: space, adamc@389: p_exp' true env e2]) adamc@387: adamc@29: | ERecord (i, xes) => box [string "({", adamc@29: space, adamc@29: string "struct", adamc@29: space, adamc@311: string ("__uws_" ^ Int.toString i), adamc@29: space, adamc@181: string "tmp", adamc@29: space, adamc@29: string "=", adamc@29: space, adamc@29: string "{", adamc@29: p_list (fn (_, e) => adamc@29: p_exp env e) xes, adamc@29: string "};", adamc@29: space, adamc@181: string "tmp;", adamc@29: space, adamc@29: string "})" ] adamc@29: | EField (e, x) => adamc@29: box [p_exp' true env e, adamc@311: string ".__uwf_", adamc@316: p_ident x] adamc@29: adamc@182: | ECase (e, pes, {disc, result}) => adamc@182: let adamc@182: val final = newGoto () adamc@182: adamc@182: val body = foldl (fn ((p, e), body) => adamc@182: let adamc@182: val exit = newGoto () adamc@182: val (pr, _) = p_pat_preamble env p adamc@182: val (p, env) = p_pat (env, adamc@182: box [string "goto", adamc@182: space, adamc@182: exit, adamc@182: string ";"], adamc@182: 0) p adamc@182: in adamc@182: box [body, adamc@182: box [string "{", adamc@182: newline, adamc@182: pr, adamc@182: newline, adamc@182: p, adamc@182: newline, adamc@182: string "result", adamc@182: space, adamc@182: string "=", adamc@182: space, adamc@182: p_exp env e, adamc@182: string ";", adamc@182: newline, adamc@182: string "goto", adamc@182: space, adamc@182: final, adamc@182: string ";", adamc@182: newline, adamc@182: string "}"], adamc@182: newline, adamc@182: exit, adamc@182: string ":", adamc@182: newline] adamc@182: end) (box []) pes adamc@182: in adamc@182: box [string "({", adamc@182: newline, adamc@182: p_typ env disc, adamc@182: space, adamc@182: string "disc0", adamc@182: space, adamc@182: string "=", adamc@182: space, adamc@182: p_exp env e, adamc@182: string ";", adamc@182: newline, adamc@182: p_typ env result, adamc@182: space, adamc@182: string "result;", adamc@182: newline, adamc@182: body, adamc@311: string "uw_error(ctx, FATAL, \"", adamc@182: string (ErrorMsg.spanToString loc), adamc@182: string ": pattern match failure\");", adamc@182: newline, adamc@182: final, adamc@182: string ":", adamc@182: space, adamc@182: string "result;", adamc@182: newline, adamc@182: string "})"] adamc@182: end adamc@181: adamc@311: | EWrite e => box [string "(uw_write(ctx, ", adamc@102: p_exp env e, adamc@311: string "), uw_unit_v)"] adamc@102: adamc@106: | ESeq (e1, e2) => box [string "(", adamc@106: p_exp env e1, adamc@106: string ",", adamc@106: space, adamc@106: p_exp env e2, adamc@106: string ")"] adamc@269: | ELet (x, t, e1, e2) => box [string "({", adamc@269: newline, adamc@269: p_typ env t, adamc@269: space, adamc@311: string "__uwr_", adamc@316: p_ident x, adamc@272: string "_", adamc@272: string (Int.toString (E.countERels env)), adamc@269: space, adamc@269: string "=", adamc@269: space, adamc@269: p_exp env e1, adamc@269: string ";", adamc@269: newline, adamc@269: p_exp (E.pushERel env x t) e2, adamc@269: string ";", adamc@269: newline, adamc@269: string "})"] adamc@269: adamc@282: | EQuery {exps, tables, rnum, state, query, body, initial, prepared} => adamc@278: let adamc@316: val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps adamc@278: val tables = ListUtil.mapConcat (fn (x, xts) => adamc@316: map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts) adamc@278: tables adamc@638: adamc@278: val outputs = exps @ tables adamc@325: val outputs = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) outputs adamc@324: adamc@324: val wontLeakStrings = notLeaky env true state adamc@324: val wontLeakAnything = notLeaky env false state adamc@278: in adamc@640: box [if wontLeakAnything then adamc@704: string "(uw_begin_region(ctx), " adamc@324: else adamc@324: box [], adamc@324: string "({", adamc@278: newline, adamc@311: string "PGconn *conn = uw_get_db(ctx);", adamc@278: newline, adamc@640: p_typ env state, adamc@640: space, adamc@640: string "acc", adamc@640: space, adamc@640: string "=", adamc@640: space, adamc@640: p_exp env initial, adamc@640: string ";", adamc@640: newline, adamc@640: string "int n, i, dummy = (uw_begin_region(ctx), 0);", adamc@640: newline, adamc@640: adamc@282: case prepared of adamc@282: NONE => box [string "char *query = ", adamc@282: p_exp env query, adamc@282: string ";", adamc@282: newline] adamc@282: | SOME _ => adamc@282: let adamc@282: val ets = getPargs query adamc@282: in adamc@282: box [p_list_sepi newline adamc@282: (fn i => fn (e, t) => adamc@282: box [p_sql_type t, adamc@282: space, adamc@282: string "arg", adamc@282: string (Int.toString (i + 1)), adamc@282: space, adamc@282: string "=", adamc@282: space, adamc@282: p_exp env e, adamc@282: string ";"]) adamc@282: ets, adamc@282: newline, adamc@282: newline, adamc@282: adamc@282: string "const char *paramValues[] = { ", adamc@282: p_list_sepi (box [string ",", space]) adamc@282: (fn i => fn (_, t) => p_ensql t (box [string "arg", adamc@282: string (Int.toString (i + 1))])) adamc@282: ets, adamc@282: string " };", adamc@282: newline, adamc@282: newline] adamc@282: end, adamc@640: adamc@282: string "PGresult *res = ", adamc@282: case prepared of adamc@295: NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" adamc@311: | SOME n => box [string "PQexecPrepared(conn, \"uw", adamc@282: string (Int.toString n), adamc@282: string "\", ", adamc@282: string (Int.toString (length (getPargs query))), adamc@295: string ", paramValues, NULL, NULL, 0);"], adamc@278: newline, adamc@278: newline, adamc@277: adamc@311: string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@278: newline, adamc@278: newline, adamc@277: adamc@278: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@278: newline, adamc@278: box [string "PQclear(res);", adamc@278: newline, adamc@311: string "uw_error(ctx, FATAL, \"", adamc@278: string (ErrorMsg.spanToString loc), adamc@282: string ": Query failed:\\n%s\\n%s\", ", adamc@282: case prepared of adamc@282: NONE => string "query" adamc@282: | SOME _ => p_exp env query, adamc@282: string ", PQerrorMessage(conn));", adamc@278: newline], adamc@278: string "}", adamc@278: newline, adamc@278: newline, adamc@277: adamc@323: string "uw_end_region(ctx);", adamc@323: newline, adamc@425: string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);", adamc@425: newline, adamc@278: string "n = PQntuples(res);", adamc@278: newline, adamc@278: string "for (i = 0; i < n; ++i) {", adamc@278: newline, adamc@278: box [string "struct", adamc@278: space, adamc@311: string "__uws_", adamc@278: string (Int.toString rnum), adamc@278: space, adamc@311: string "__uwr_r_", adamc@278: string (Int.toString (E.countERels env)), adamc@278: string ";", adamc@278: newline, adamc@278: p_typ env state, adamc@278: space, adamc@311: string "__uwr_acc_", adamc@278: string (Int.toString (E.countERels env + 1)), adamc@278: space, adamc@278: string "=", adamc@278: space, adamc@278: string "acc;", adamc@278: newline, adamc@278: newline, adamc@278: adamc@278: p_list_sepi (box []) (fn i => adamc@278: fn (proj, t) => adamc@311: box [string "__uwr_r_", adamc@278: string (Int.toString (E.countERels env)), adamc@278: string ".", adamc@278: string proj, adamc@278: space, adamc@278: string "=", adamc@278: space, adamc@467: p_getcol wontLeakStrings env t i, adamc@278: string ";", adamc@278: newline]) outputs, adamc@278: adamc@278: newline, adamc@278: newline, adamc@278: adamc@278: string "acc", adamc@278: space, adamc@278: string "=", adamc@278: space, adamc@278: p_exp (E.pushERel adamc@278: (E.pushERel env "r" (TRecord rnum, loc)) adamc@278: "acc" state) adamc@278: body, adamc@278: string ";", adamc@278: newline], adamc@278: string "}", adamc@278: newline, adamc@278: newline, adamc@425: string "uw_pop_cleanup(ctx);", adamc@278: newline, adamc@324: if wontLeakAnything then adamc@324: box [string "uw_end_region(ctx);", adamc@324: newline] adamc@324: else adamc@324: box [], adamc@278: string "acc;", adamc@278: newline, adamc@704: string "})", adamc@704: if wontLeakAnything then adamc@704: string ")" adamc@704: else adamc@704: box []] adamc@278: end adamc@106: adamc@307: | EDml {dml, prepared} => adamc@337: box [string "(uw_begin_region(ctx), ({", adamc@307: newline, adamc@311: string "PGconn *conn = uw_get_db(ctx);", adamc@307: newline, adamc@307: case prepared of adamc@307: NONE => box [string "char *dml = ", adamc@307: p_exp env dml, adamc@307: string ";", adamc@307: newline] adamc@307: | SOME _ => adamc@307: let adamc@307: val ets = getPargs dml adamc@307: in adamc@307: box [p_list_sepi newline adamc@307: (fn i => fn (e, t) => adamc@307: box [p_sql_type t, adamc@307: space, adamc@307: string "arg", adamc@307: string (Int.toString (i + 1)), adamc@307: space, adamc@307: string "=", adamc@307: space, adamc@307: p_exp env e, adamc@307: string ";"]) adamc@307: ets, adamc@307: newline, adamc@307: newline, adamc@307: adamc@307: string "const char *paramValues[] = { ", adamc@307: p_list_sepi (box [string ",", space]) adamc@307: (fn i => fn (_, t) => p_ensql t (box [string "arg", adamc@307: string (Int.toString (i + 1))])) adamc@307: ets, adamc@307: string " };", adamc@307: newline, adamc@307: newline] adamc@307: end, adamc@307: newline, adamc@307: newline, adamc@307: string "PGresult *res = ", adamc@307: case prepared of adamc@307: NONE => string "PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);" adamc@311: | SOME n => box [string "PQexecPrepared(conn, \"uw", adamc@307: string (Int.toString n), adamc@307: string "\", ", adamc@307: string (Int.toString (length (getPargs dml))), adamc@307: string ", paramValues, NULL, NULL, 0);"], adamc@307: newline, adamc@307: newline, adamc@307: adamc@311: string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", adamc@307: newline, adamc@307: newline, adamc@307: adamc@307: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@307: newline, adamc@688: box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {", adamc@688: box [newline, adamc@688: string "PQclear(res);", adamc@688: newline, adamc@688: string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");", adamc@688: newline], adamc@688: string "}", adamc@688: newline, adamc@688: string "PQclear(res);", adamc@307: newline, adamc@311: string "uw_error(ctx, FATAL, \"", adamc@307: string (ErrorMsg.spanToString loc), adamc@307: string ": DML failed:\\n%s\\n%s\", ", adamc@307: case prepared of adamc@307: NONE => string "dml" adamc@307: | SOME _ => p_exp env dml, adamc@307: string ", PQerrorMessage(conn));", adamc@307: newline], adamc@307: string "}", adamc@307: newline, adamc@307: newline, adamc@307: adamc@307: string "PQclear(res);", adamc@307: newline, adamc@337: string "uw_end_region(ctx);", adamc@337: newline, adamc@311: string "uw_unit_v;", adamc@307: newline, adamc@337: string "}))"] adamc@307: adamc@338: | ENextval {seq, prepared} => adamc@338: let adamc@486: val query = case seq of adamc@486: (EPrim (Prim.String s), loc) => adamc@486: (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) adamc@486: | _ => adamc@486: let adamc@486: val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) adamc@486: in adamc@486: (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) adamc@486: end adamc@338: in adamc@338: box [string "(uw_begin_region(ctx), ", adamc@338: string "({", adamc@338: newline, adamc@338: string "PGconn *conn = uw_get_db(ctx);", adamc@338: newline, adamc@338: case prepared of adamc@338: NONE => box [string "char *query = ", adamc@338: p_exp env query, adamc@338: string ";", adamc@338: newline] adamc@338: | SOME _ => adamc@338: box [], adamc@338: newline, adamc@338: string "PGresult *res = ", adamc@338: case prepared of adamc@338: NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" adamc@338: | SOME n => box [string "PQexecPrepared(conn, \"uw", adamc@338: string (Int.toString n), adamc@338: string "\", 0, NULL, NULL, NULL, 0);"], adamc@338: newline, adamc@338: string "uw_Basis_int n;", adamc@338: newline, adamc@338: newline, adamc@338: adamc@338: string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");", adamc@338: newline, adamc@338: newline, adamc@338: adamc@338: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@338: newline, adamc@338: box [string "PQclear(res);", adamc@338: newline, adamc@338: string "uw_error(ctx, FATAL, \"", adamc@338: string (ErrorMsg.spanToString loc), adamc@338: string ": Query failed:\\n%s\\n%s\", ", adamc@338: case prepared of adamc@338: NONE => string "query" adamc@338: | SOME _ => p_exp env query, adamc@338: string ", PQerrorMessage(conn));", adamc@338: newline], adamc@338: string "}", adamc@338: newline, adamc@338: newline, adamc@338: adamc@338: string "uw_end_region(ctx);", adamc@338: newline, adamc@338: string "n = PQntuples(res);", adamc@338: newline, adamc@338: string "if (n != 1) {", adamc@338: newline, adamc@338: box [string "PQclear(res);", adamc@338: newline, adamc@338: string "uw_error(ctx, FATAL, \"", adamc@338: string (ErrorMsg.spanToString loc), adamc@338: string ": Wrong number of result rows:\\n%s\\n%s\", ", adamc@338: case prepared of adamc@338: NONE => string "query" adamc@338: | SOME _ => p_exp env query, adamc@338: string ", PQerrorMessage(conn));", adamc@338: newline], adamc@338: string "}", adamc@338: newline, adamc@338: newline, adamc@338: adamc@338: string "n = ", adamc@338: p_unsql true env (TFfi ("Basis", "int"), loc) adamc@338: (string "PQgetvalue(res, 0, 0)"), adamc@338: string ";", adamc@338: newline, adamc@338: string "PQclear(res);", adamc@338: newline, adamc@338: string "n;", adamc@338: newline, adamc@338: string "}))"] adamc@338: end adamc@338: adamc@463: | EUnurlify (e, t) => adamc@463: let adamc@463: fun getIt () = adamc@463: if isUnboxable t then adamc@463: unurlify env t adamc@463: else adamc@463: box [string "({", adamc@463: newline, adamc@463: p_typ env t, adamc@463: string " *tmp = uw_malloc(ctx, sizeof(", adamc@463: p_typ env t, adamc@463: string "));", adamc@463: newline, adamc@463: string "*tmp = ", adamc@463: unurlify env t, adamc@463: string ";", adamc@463: newline, adamc@463: string "tmp;", adamc@463: newline, adamc@463: string "})"] adamc@463: in adamc@463: box [string "({", adamc@463: newline, adamc@493: string "uw_Basis_string request = uw_Basis_maybe_strdup(ctx, ", adamc@463: p_exp env e, adamc@492: string ");", adamc@463: newline, adamc@463: newline, adamc@463: string "(request ? ", adamc@463: getIt (), adamc@463: string " : NULL);", adamc@463: newline, adamc@463: string "})"] adamc@463: end adamc@463: adamc@29: and p_exp env = p_exp' false env adamc@29: adamc@129: fun p_fun env (fx, n, args, ran, e) = adamc@129: let adamc@129: val nargs = length args adamc@129: val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args adamc@129: in adamc@129: box [string "static", adamc@129: space, adamc@129: p_typ env ran, adamc@129: space, adamc@316: string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), adamc@129: string "(", adamc@129: p_list_sep (box [string ",", space]) (fn x => x) adamc@311: (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => adamc@129: box [p_typ env dom, adamc@129: space, adamc@129: p_rel env' (nargs - i - 1)]) args), adamc@129: string ")", adamc@129: space, adamc@129: string "{", adamc@129: newline, adamc@638: box [string "return(", adamc@638: p_exp env' e, adamc@638: string ");"], adamc@129: newline, adamc@129: string "}"] adamc@129: end adamc@129: adamc@129: fun p_decl env (dAll as (d, _) : decl) = adamc@29: case d of adamc@29: DStruct (n, xts) => adamc@196: let adamc@196: val env = E.declBinds env dAll adamc@196: in adamc@196: box [string "struct", adamc@196: space, adamc@311: string ("__uws_" ^ Int.toString n), adamc@196: space, adamc@196: string "{", adamc@196: newline, adamc@196: p_list_sep (box []) (fn (x, t) => box [p_typ env t, adamc@196: space, adamc@311: string "__uwf_", adamc@316: p_ident x, adamc@196: string ";", adamc@196: newline]) xts, adamc@196: string "};"] adamc@196: end adamc@188: | DDatatype (Enum, x, n, xncs) => adamc@188: box [string "enum", adamc@188: space, adamc@316: string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), adamc@188: space, adamc@188: string "{", adamc@188: space, adamc@316: p_list_sep (box [string ",", space]) (fn (x, n, _) => adamc@316: string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs, adamc@188: space, adamc@188: string "};"] adamc@198: | DDatatype (Option, _, _, _) => box [] adamc@188: | DDatatype (Default, x, n, xncs) => adamc@165: let adamc@165: val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE adamc@165: | (x, n, SOME t) => SOME (x, n, t)) xncs adamc@165: in adamc@165: box [string "enum", adamc@165: space, adamc@316: string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), adamc@165: space, adamc@165: string "{", adamc@165: space, adamc@316: p_list_sep (box [string ",", space]) (fn (x, n, _) => adamc@316: string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs, adamc@165: space, adamc@165: string "};", adamc@165: newline, adamc@165: newline, adamc@165: string "struct", adamc@165: space, adamc@316: string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n), adamc@165: space, adamc@165: string "{", adamc@165: newline, adamc@165: string "enum", adamc@165: space, adamc@316: string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), adamc@165: space, adamc@165: string "tag;", adamc@165: newline, adamc@165: box (case xncsArgs of adamc@165: [] => [] adamc@165: | _ => [string "union", adamc@165: space, adamc@165: string "{", adamc@165: newline, adamc@165: p_list_sep newline (fn (x, n, t) => box [p_typ env t, adamc@165: space, adamc@316: string ("uw_" ^ ident x), adamc@165: string ";"]) xncsArgs, adamc@165: newline, adamc@165: string "}", adamc@165: space, adamc@165: string "data;", adamc@165: newline]), adamc@165: string "};"] adamc@188: end adamc@29: adamc@196: | DDatatypeForward _ => box [] adamc@196: adamc@29: | DVal (x, n, t, e) => adamc@29: box [p_typ env t, adamc@29: space, adamc@316: string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n), adamc@29: space, adamc@29: string "=", adamc@29: space, adamc@29: p_exp env e, adamc@29: string ";"] adamc@129: | DFun vi => p_fun env vi adamc@129: | DFunRec vis => adamc@29: let adamc@129: val env = E.declBinds env dAll adamc@29: in adamc@129: box [p_list_sep newline (fn (fx, n, args, ran, _) => adamc@129: box [string "static", adamc@129: space, adamc@129: p_typ env ran, adamc@129: space, adamc@316: string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), adamc@311: string "(uw_context,", adamc@129: space, adamc@129: p_list_sep (box [string ",", space]) adamc@129: (fn (_, dom) => p_typ env dom) args, adamc@129: string ");"]) vis, adamc@29: newline, adamc@129: p_list_sep newline (p_fun env) vis, adamc@129: newline] adamc@29: end adamc@707: | DTable (x, _, pk, csts) => box [string "/* SQL table ", adamc@707: string x, adamc@707: space, adamc@707: case pk of adamc@707: "" => box [] adamc@707: | _ => box [string "keys", adamc@707: space, adamc@707: string pk, adamc@707: space], adamc@707: string "constraints", adamc@707: space, adamc@707: p_list (fn (x, v) => box [string x, adamc@707: space, adamc@707: string ":", adamc@707: space, adamc@707: string v]) csts, adamc@707: space, adamc@707: string " */", adamc@707: newline] adamc@338: | DSequence x => box [string "/* SQL sequence ", adamc@338: string x, adamc@338: string " */", adamc@338: newline] adamc@687: | DDatabase {name, expunge, initialize} => adamc@687: box [string "static void uw_db_validate(uw_context);", adamc@687: newline, adamc@687: string "static void uw_db_prepare(uw_context);", adamc@687: newline, adamc@687: newline, adamc@687: string "void uw_db_init(uw_context ctx) {", adamc@687: newline, adamc@687: string "PGconn *conn = PQconnectdb(\"", adamc@687: string (String.toString name), adamc@687: string "\");", adamc@687: newline, adamc@687: string "if (conn == NULL) uw_error(ctx, BOUNDED_RETRY, ", adamc@687: string "\"libpq can't allocate a connection.\");", adamc@687: newline, adamc@687: string "if (PQstatus(conn) != CONNECTION_OK) {", adamc@687: newline, adamc@687: box [string "char msg[1024];", adamc@687: newline, adamc@687: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@687: newline, adamc@687: string "msg[1023] = 0;", adamc@687: newline, adamc@687: string "PQfinish(conn);", adamc@687: newline, adamc@687: string "uw_error(ctx, BOUNDED_RETRY, ", adamc@687: string "\"Connection to Postgres server failed: %s\", msg);"], adamc@687: newline, adamc@687: string "}", adamc@687: newline, adamc@687: string "uw_set_db(ctx, conn);", adamc@687: newline, adamc@687: string "uw_db_validate(ctx);", adamc@687: newline, adamc@687: string "uw_db_prepare(ctx);", adamc@687: newline, adamc@687: string "}", adamc@687: newline, adamc@687: newline, adamc@687: string "void uw_db_close(uw_context ctx) {", adamc@687: newline, adamc@687: string "PQfinish(uw_get_db(ctx));", adamc@687: newline, adamc@687: string "}", adamc@687: newline, adamc@687: newline, adamc@424: adamc@687: string "int uw_db_begin(uw_context ctx) {", adamc@687: newline, adamc@687: string "PGconn *conn = uw_get_db(ctx);", adamc@687: newline, adamc@687: string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");", adamc@687: newline, adamc@687: newline, adamc@687: string "if (res == NULL) return 1;", adamc@687: newline, adamc@687: newline, adamc@687: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@687: box [string "PQclear(res);", adamc@687: newline, adamc@687: string "return 1;", adamc@687: newline], adamc@687: string "}", adamc@687: newline, adamc@687: string "return 0;", adamc@687: newline, adamc@687: string "}", adamc@687: newline, adamc@687: newline, adamc@424: adamc@687: string "int uw_db_commit(uw_context ctx) {", adamc@687: newline, adamc@687: string "PGconn *conn = uw_get_db(ctx);", adamc@687: newline, adamc@687: string "PGresult *res = PQexec(conn, \"COMMIT\");", adamc@687: newline, adamc@687: newline, adamc@687: string "if (res == NULL) return 1;", adamc@687: newline, adamc@687: newline, adamc@687: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@687: box [string "PQclear(res);", adamc@687: newline, adamc@687: string "return 1;", adamc@687: newline], adamc@687: string "}", adamc@687: newline, adamc@687: string "return 0;", adamc@687: newline, adamc@687: string "}", adamc@687: newline, adamc@687: newline, adamc@424: adamc@687: string "int uw_db_rollback(uw_context ctx) {", adamc@687: newline, adamc@687: string "PGconn *conn = uw_get_db(ctx);", adamc@687: newline, adamc@687: string "PGresult *res = PQexec(conn, \"ROLLBACK\");", adamc@687: newline, adamc@687: newline, adamc@687: string "if (res == NULL) return 1;", adamc@687: newline, adamc@687: newline, adamc@687: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@687: box [string "PQclear(res);", adamc@687: newline, adamc@687: string "return 1;", adamc@687: newline], adamc@687: string "}", adamc@687: newline, adamc@687: string "return 0;", adamc@687: newline, adamc@687: string "}", adamc@687: newline, adamc@687: newline, adamc@683: adamc@687: string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {", adamc@687: newline, adamc@687: box [p_enamed env expunge, adamc@687: string "(ctx, cli);", adamc@687: newline], adamc@687: string "}", adamc@687: newline, adamc@687: newline, adamc@687: adamc@687: string "void uw_initializer(uw_context ctx) {", adamc@687: newline, adamc@687: box [p_enamed env initialize, adamc@687: string "(ctx, uw_unit_v);", adamc@687: newline], adamc@687: string "}", adamc@687: newline] adamc@29: adamc@467: | DPreparedStatements [] => adamc@467: box [string "static void uw_db_prepare(uw_context ctx) {", adamc@467: newline, adamc@467: string "}"] adamc@282: | DPreparedStatements ss => adamc@311: box [string "static void uw_db_prepare(uw_context ctx) {", adamc@282: newline, adamc@311: string "PGconn *conn = uw_get_db(ctx);", adamc@282: newline, adamc@282: string "PGresult *res;", adamc@282: newline, adamc@282: newline, adamc@282: adamc@282: p_list_sepi newline (fn i => fn (s, n) => adamc@311: box [string "res = PQprepare(conn, \"uw", adamc@282: string (Int.toString i), adamc@282: string "\", \"", adamc@282: string (String.toString s), adamc@282: string "\", ", adamc@282: string (Int.toString n), adamc@282: string ", NULL);", adamc@282: newline, adamc@282: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@282: newline, adamc@282: box [string "char msg[1024];", adamc@282: newline, adamc@282: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@282: newline, adamc@282: string "msg[1023] = 0;", adamc@282: newline, adamc@282: string "PQclear(res);", adamc@282: newline, adamc@282: string "PQfinish(conn);", adamc@282: newline, adamc@311: string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n", adamc@282: string (String.toString s), adamc@282: string "\\n%s\", msg);", adamc@282: newline], adamc@282: string "}", adamc@282: newline, adamc@282: string "PQclear(res);", adamc@282: newline]) adamc@282: ss, adamc@282: adamc@282: string "}"] adamc@282: adamc@569: | DJavaScript s => box [string "static char jslib[] = \"", adamc@569: string (String.toString s), adamc@569: string "\";"] adamc@569: adamc@144: datatype 'a search = adamc@144: Found of 'a adamc@144: | NotFound adamc@144: | Error adamc@120: adamc@467: fun p_sqltype'' env (tAll as (t, loc)) = adamc@275: case t of adamc@275: TFfi ("Basis", "int") => "int8" adamc@275: | TFfi ("Basis", "float") => "float8" adamc@275: | TFfi ("Basis", "string") => "text" adamc@275: | TFfi ("Basis", "bool") => "bool" adamc@438: | TFfi ("Basis", "time") => "timestamp" adamc@682: | TFfi ("Basis", "channel") => "int8" adamc@682: | TFfi ("Basis", "client") => "int4" adamc@275: | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; adamc@275: Print.eprefaces' [("Type", p_typ env tAll)]; adamc@275: "ERROR") adamc@275: adamc@467: fun p_sqltype' env (tAll as (t, loc)) = adamc@467: case t of adamc@467: (TOption t, _) => p_sqltype'' env t adamc@467: | _ => p_sqltype'' env t ^ " NOT NULL" adamc@467: adamc@275: fun p_sqltype env t = string (p_sqltype' env t) adamc@101: adamc@467: fun p_sqltype_base' env t = adamc@467: case t of adamc@467: (TOption t, _) => p_sqltype'' env t adamc@467: | _ => p_sqltype'' env t adamc@467: adamc@467: fun p_sqltype_base env t = string (p_sqltype_base' env t) adamc@467: adamc@467: fun is_not_null t = adamc@467: case t of adamc@467: (TOption _, _) => false adamc@467: | _ => true adamc@467: adamc@101: fun p_file env (ds, ps) = adamc@29: let adamc@101: val (pds, env) = ListUtil.foldlMap (fn (d, env) => adamc@638: (p_decl env d, adamc@638: E.declBinds env d)) adamc@101: env ds adamc@144: adamc@643: val fields = foldl (fn ((ek, _, _, ts, _, _), fields) => adamc@144: case ek of adamc@144: Core.Link => fields adamc@608: | Core.Rpc => fields adamc@144: | Core.Action => adamc@280: case List.nth (ts, length ts - 2) of adamc@144: (TRecord i, _) => adamc@144: let adamc@144: val xts = E.lookupStruct env i adamc@144: val xtsSet = SS.addList (SS.empty, map #1 xts) adamc@144: in adamc@144: foldl (fn ((x, _), fields) => adamc@144: let adamc@144: val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) adamc@144: in adamc@144: SM.insert (fields, x, SS.union (SS.delete (xtsSet, x), adamc@144: xtsSet')) adamc@144: end) fields xts adamc@144: end adamc@144: | _ => raise Fail "CjrPrint: Last argument of action isn't record") adamc@144: SM.empty ps adamc@144: adamc@144: val fnums = SM.foldli (fn (x, xs, fnums) => adamc@144: let adamc@144: val unusable = SS.foldl (fn (x', unusable) => adamc@144: case SM.find (fnums, x') of adamc@144: NONE => unusable adamc@144: | SOME n => IS.add (unusable, n)) adamc@144: IS.empty xs adamc@144: adamc@144: fun findAvailable n = adamc@144: if IS.member (unusable, n) then adamc@144: findAvailable (n + 1) adamc@144: else adamc@144: n adamc@144: in adamc@144: SM.insert (fnums, x, findAvailable 0) adamc@144: end) adamc@144: SM.empty fields adamc@144: adamc@144: fun makeSwitch (fnums, i) = adamc@144: case SM.foldl (fn (n, NotFound) => Found n adamc@144: | (n, Error) => Error adamc@144: | (n, Found n') => if n = n' then adamc@144: Found n' adamc@144: else adamc@144: Error) NotFound fnums of adamc@144: NotFound => box [string "return", adamc@144: space, adamc@144: string "-1;"] adamc@144: | Found n => box [string "return", adamc@144: space, adamc@144: string (Int.toString n), adamc@144: string ";"] adamc@144: | Error => adamc@144: let adamc@144: val cmap = SM.foldli (fn (x, n, cmap) => adamc@144: let adamc@144: val ch = if i < size x then adamc@144: String.sub (x, i) adamc@144: else adamc@144: chr 0 adamc@144: adamc@144: val fnums = case CM.find (cmap, ch) of adamc@144: NONE => SM.empty adamc@144: | SOME fnums => fnums adamc@144: val fnums = SM.insert (fnums, x, n) adamc@144: in adamc@144: CM.insert (cmap, ch, fnums) adamc@144: end) adamc@144: CM.empty fnums adamc@144: adamc@144: val cmap = CM.listItemsi cmap adamc@144: in adamc@144: case cmap of adamc@144: [(_, fnums)] => adamc@144: box [string "if", adamc@144: space, adamc@144: string "(name[", adamc@144: string (Int.toString i), adamc@144: string "]", adamc@144: space, adamc@144: string "==", adamc@144: space, adamc@144: string "0)", adamc@144: space, adamc@144: string "return", adamc@144: space, adamc@144: string "-1;", adamc@144: newline, adamc@144: makeSwitch (fnums, i+1)] adamc@144: | _ => adamc@144: box [string "switch", adamc@144: space, adamc@144: string "(name[", adamc@144: string (Int.toString i), adamc@144: string "])", adamc@144: space, adamc@144: string "{", adamc@144: newline, adamc@144: box (map (fn (ch, fnums) => adamc@144: box [string "case", adamc@144: space, adamc@144: if ch = chr 0 then adamc@144: string "0:" adamc@144: else adamc@144: box [string "'", adamc@144: string (Char.toString ch), adamc@144: string "':"], adamc@144: newline, adamc@144: makeSwitch (fnums, i+1), adamc@144: newline]) cmap), adamc@144: string "default:", adamc@144: newline, adamc@144: string "return", adamc@144: space, adamc@144: string "-1;", adamc@144: newline, adamc@144: string "}"] adamc@144: end adamc@144: adamc@643: fun p_page (ek, s, n, ts, ran, side) = adamc@144: let adamc@144: val (ts, defInputs, inputsVar) = adamc@144: case ek of adamc@314: Core.Link => (List.take (ts, length ts - 1), string "", string "") adamc@608: | Core.Rpc => (List.take (ts, length ts - 1), string "", string "") adamc@144: | Core.Action => adamc@280: case List.nth (ts, length ts - 2) of adamc@144: (TRecord i, _) => adamc@144: let adamc@144: val xts = E.lookupStruct env i adamc@144: in adamc@280: (List.take (ts, length ts - 2), adamc@144: box [box (map (fn (x, t) => box [p_typ env t, adamc@144: space, adamc@311: string "uw_input_", adamc@316: p_ident x, adamc@144: string ";", adamc@144: newline]) xts), adamc@144: newline, adamc@144: box (map (fn (x, t) => adamc@144: let adamc@144: val n = case SM.find (fnums, x) of adamc@144: NONE => raise Fail "CjrPrint: Can't find in fnums" adamc@144: | SOME n => n adamc@190: adamc@190: val f = case t of adamc@190: (TFfi ("Basis", "bool"), _) => "optional_" adamc@190: | _ => "" adamc@144: in adamc@311: box [string "request = uw_get_", adamc@190: string f, adamc@190: string "input(ctx, ", adamc@144: string (Int.toString n), adamc@144: string ");", adamc@144: newline, adamc@433: string "if (request == NULL)", adamc@144: newline, adamc@433: box [string "uw_error(ctx, FATAL, \"Missing input ", adamc@144: string x, adamc@433: string "\");"], adamc@144: newline, adamc@311: string "uw_input_", adamc@316: p_ident x, adamc@144: space, adamc@144: string "=", adamc@144: space, adamc@463: unurlify env t, adamc@144: string ";", adamc@144: newline] adamc@144: end) xts), adamc@311: string "struct __uws_", adamc@144: string (Int.toString i), adamc@144: space, adamc@311: string "uw_inputs", adamc@144: space, adamc@144: string "= {", adamc@144: newline, adamc@311: box (map (fn (x, _) => box [string "uw_input_", adamc@316: p_ident x, adamc@144: string ",", adamc@144: newline]) xts), adamc@144: string "};", adamc@144: newline], adamc@144: box [string ",", adamc@144: space, adamc@311: string "uw_inputs"]) adamc@144: end adamc@144: adamc@144: | _ => raise Fail "CjrPrint: Last argument to an action isn't a record" adamc@144: in adamc@144: box [string "if (!strncmp(request, \"", adamc@144: string (String.toString s), adamc@144: string "\", ", adamc@144: string (Int.toString (size s)), adamc@198: string ") && (request[", adamc@198: string (Int.toString (size s)), adamc@198: string "] == 0 || request[", adamc@198: string (Int.toString (size s)), adamc@198: string "] == '/')) {", adamc@144: newline, adamc@144: string "request += ", adamc@144: string (Int.toString (size s)), adamc@144: string ";", adamc@144: newline, adamc@144: string "if (*request == '/') ++request;", adamc@144: newline, adamc@609: box (case ek of adamc@610: Core.Rpc => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");", adamc@610: newline] adamc@609: | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", adamc@609: newline, adamc@609: string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", adamc@609: newline, adamc@609: string "uw_write(ctx, \"\");", adamc@643: newline, adamc@643: string "uw_set_script_header(ctx, \"", adamc@643: string (case side of adamc@693: ServerOnly => "" adamc@693: | _ => "\\n"), adamc@643: string "\");", adamc@693: newline, adamc@693: string "uw_set_needs_push(ctx, ", adamc@693: string (case side of adamc@693: ServerAndPullAndPush => "1" adamc@693: | _ => "0"), adamc@693: string ");", adamc@693: newline, adamc@667: string "uw_set_url_prefix(ctx, \"", adamc@667: string (!Monoize.urlPrefix), adamc@667: string "\");", adamc@609: newline]), adamc@682: string "uw_login(ctx);", adamc@682: newline, adamc@144: box [string "{", adamc@144: newline, adamc@144: box (ListUtil.mapi (fn (i, t) => box [p_typ env t, adamc@144: space, adamc@144: string "arg", adamc@144: string (Int.toString i), adamc@144: space, adamc@144: string "=", adamc@144: space, adamc@463: unurlify env t, adamc@144: string ";", adamc@144: newline]) ts), adamc@144: defInputs, adamc@609: box (case ek of adamc@609: Core.Rpc => [p_typ env ran, adamc@609: space, adamc@610: string "it0", adamc@609: space, adamc@609: string "=", adamc@609: space] adamc@609: | _ => []), adamc@144: p_enamed env n, adamc@144: string "(", adamc@144: p_list_sep (box [string ",", space]) adamc@144: (fn x => x) adamc@272: (string "ctx" adamc@280: :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), adamc@144: inputsVar, adamc@311: string ", uw_unit_v);", adamc@144: newline, adamc@609: box (case ek of adamc@610: Core.Rpc => [urlify env ran] adamc@609: | _ => [string "uw_write(ctx, \"\");", adamc@609: newline]), adamc@144: string "return;", adamc@144: newline, adamc@144: string "}", adamc@144: newline, adamc@144: string "}"] adamc@144: ] adamc@144: end adamc@144: adamc@144: val pds' = map p_page ps adamc@275: adamc@707: val tables = List.mapPartial (fn (DTable (s, xts, _, _), _) => SOME (s, xts) adamc@275: | _ => NONE) ds adamc@377: val sequences = List.mapPartial (fn (DSequence s, _) => SOME s adamc@377: | _ => NONE) ds adamc@275: adamc@275: val validate = adamc@311: box [string "static void uw_db_validate(uw_context ctx) {", adamc@275: newline, adamc@311: string "PGconn *conn = uw_get_db(ctx);", adamc@275: newline, adamc@275: string "PGresult *res;", adamc@275: newline, adamc@275: newline, adamc@275: p_list_sep newline adamc@275: (fn (s, xts) => adamc@275: let adamc@377: val sl = CharVector.map Char.toLower s adamc@377: adamc@275: val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" adamc@377: ^ sl ^ "'" adamc@275: adamc@275: val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", adamc@377: sl, adamc@275: "') AND (", adamc@275: String.concatWith " OR " adamc@275: (map (fn (x, t) => adamc@311: String.concat ["(attname = 'uw_", adamc@275: CharVector.map adamc@316: Char.toLower (ident x), adamc@275: "' AND atttypid = (SELECT oid FROM pg_type", adamc@275: " WHERE typname = '", adamc@467: p_sqltype_base' env t, adamc@467: "') AND attnotnull = ", adamc@467: if is_not_null t then adamc@467: "TRUE" adamc@467: else adamc@467: "FALSE", adamc@467: ")"]) xts), adamc@275: ")"] adamc@275: adamc@275: val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", adamc@377: sl, adamc@325: "') AND attname LIKE 'uw_%'"] adamc@275: in adamc@275: box [string "res = PQexec(conn, \"", adamc@275: string q, adamc@275: string "\");", adamc@275: newline, adamc@275: newline, adamc@275: string "if (res == NULL) {", adamc@275: newline, adamc@275: box [string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@275: newline, adamc@275: box [string "char msg[1024];", adamc@275: newline, adamc@275: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@275: newline, adamc@275: string "msg[1023] = 0;", adamc@275: newline, adamc@275: string "PQclear(res);", adamc@275: newline, adamc@275: string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@275: string q, adamc@275: string "\\n%s\", msg);", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", adamc@275: newline, adamc@275: box [string "PQclear(res);", adamc@275: newline, adamc@275: string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Table '", adamc@275: string s, adamc@275: string "' does not exist.\");", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "PQclear(res);", adamc@275: newline, adamc@275: adamc@275: string "res = PQexec(conn, \"", adamc@275: string q', adamc@275: string "\");", adamc@275: newline, adamc@275: newline, adamc@275: string "if (res == NULL) {", adamc@275: newline, adamc@275: box [string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@275: newline, adamc@275: box [string "char msg[1024];", adamc@275: newline, adamc@275: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@275: newline, adamc@275: string "msg[1023] = 0;", adamc@275: newline, adamc@275: string "PQclear(res);", adamc@275: newline, adamc@275: string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@275: string q', adamc@275: string "\\n%s\", msg);", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "if (strcmp(PQgetvalue(res, 0, 0), \"", adamc@275: string (Int.toString (length xts)), adamc@275: string "\")) {", adamc@275: newline, adamc@275: box [string "PQclear(res);", adamc@275: newline, adamc@275: string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Table '", adamc@275: string s, adamc@275: string "' has the wrong column types.\");", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "PQclear(res);", adamc@275: newline, adamc@275: newline, adamc@275: adamc@275: string "res = PQexec(conn, \"", adamc@275: string q'', adamc@275: string "\");", adamc@275: newline, adamc@275: newline, adamc@275: string "if (res == NULL) {", adamc@275: newline, adamc@275: box [string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@275: newline, adamc@275: box [string "char msg[1024];", adamc@275: newline, adamc@275: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@275: newline, adamc@275: string "msg[1023] = 0;", adamc@275: newline, adamc@275: string "PQclear(res);", adamc@275: newline, adamc@275: string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@275: string q'', adamc@275: string "\\n%s\", msg);", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "if (strcmp(PQgetvalue(res, 0, 0), \"", adamc@275: string (Int.toString (length xts)), adamc@275: string "\")) {", adamc@275: newline, adamc@275: box [string "PQclear(res);", adamc@275: newline, adamc@275: string "PQfinish(conn);", adamc@275: newline, adamc@311: string "uw_error(ctx, FATAL, \"Table '", adamc@275: string s, adamc@275: string "' has extra columns.\");", adamc@275: newline], adamc@275: string "}", adamc@275: newline, adamc@275: newline, adamc@275: string "PQclear(res);", adamc@275: newline] adamc@275: end) tables, adamc@377: adamc@377: p_list_sep newline adamc@377: (fn s => adamc@377: let adamc@377: val sl = CharVector.map Char.toLower s adamc@377: adamc@377: val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" adamc@377: ^ sl ^ "' AND relkind = 'S'" adamc@377: in adamc@377: box [string "res = PQexec(conn, \"", adamc@377: string q, adamc@377: string "\");", adamc@377: newline, adamc@377: newline, adamc@377: string "if (res == NULL) {", adamc@377: newline, adamc@377: box [string "PQfinish(conn);", adamc@377: newline, adamc@377: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@377: newline], adamc@377: string "}", adamc@377: newline, adamc@377: newline, adamc@377: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@377: newline, adamc@377: box [string "char msg[1024];", adamc@377: newline, adamc@377: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@377: newline, adamc@377: string "msg[1023] = 0;", adamc@377: newline, adamc@377: string "PQclear(res);", adamc@377: newline, adamc@377: string "PQfinish(conn);", adamc@377: newline, adamc@377: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@377: string q, adamc@377: string "\\n%s\", msg);", adamc@377: newline], adamc@377: string "}", adamc@377: newline, adamc@377: newline, adamc@377: string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", adamc@377: newline, adamc@377: box [string "PQclear(res);", adamc@377: newline, adamc@377: string "PQfinish(conn);", adamc@377: newline, adamc@377: string "uw_error(ctx, FATAL, \"Sequence '", adamc@377: string s, adamc@377: string "' does not exist.\");", adamc@377: newline], adamc@377: string "}", adamc@377: newline, adamc@377: newline, adamc@377: string "PQclear(res);", adamc@377: newline] adamc@377: end) sequences, adamc@377: adamc@275: string "}"] adamc@432: adamc@432: val hasDb = List.exists (fn (DDatabase _, _) => true | _ => false) ds adamc@29: in adamc@144: box [string "#include ", adamc@144: newline, adamc@144: string "#include ", adamc@144: newline, adamc@272: string "#include ", adamc@272: newline, adamc@390: string "#include ", adamc@390: newline, adamc@432: if hasDb then adamc@432: box [string "#include ", adamc@432: newline] adamc@432: else adamc@432: box [], adamc@144: newline, adamc@378: string "#include \"", adamc@378: string (OS.Path.joinDirFile {dir = Config.includ, adamc@378: file = "urweb.h"}), adamc@378: string "\"", adamc@101: newline, adamc@101: newline, adamc@101: p_list_sep newline (fn x => x) pds, adamc@101: newline, adamc@311: string "int uw_inputs_len = ", adamc@144: string (Int.toString (SM.foldl Int.max 0 fnums + 1)), adamc@144: string ";", adamc@144: newline, adamc@673: string "int uw_timeout = ", adamc@673: string (Int.toString (!timeout)), adamc@673: string ";", adamc@673: newline, adamc@144: newline, adamc@311: string "int uw_input_num(char *name) {", adamc@144: newline, adamc@144: makeSwitch (fnums, 0), adamc@144: string "}", adamc@144: newline, adamc@144: newline, adamc@311: string "void uw_handle(uw_context ctx, char *request) {", adamc@101: newline, adamc@569: string "if (!strcmp(request, \"/app.js\")) {", adamc@569: newline, adamc@569: box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", adamc@569: newline, adamc@569: string "uw_write(ctx, jslib);", adamc@569: newline, adamc@569: string "return;", adamc@569: newline], adamc@569: string "}", adamc@569: newline, adamc@101: p_list_sep newline (fn x => x) pds', adamc@101: newline, adamc@387: string "uw_error(ctx, FATAL, \"Unknown page\");", adamc@387: newline, adamc@101: string "}", adamc@275: newline, adamc@275: newline, adamc@432: if hasDb then adamc@432: validate adamc@432: else adamc@432: box [], adamc@376: newline, adamc@376: if List.exists (fn (DDatabase _, _) => true | _ => false) ds then adamc@376: box [] adamc@376: else adamc@376: box [newline, adamc@376: string "void uw_db_init(uw_context ctx) { };", adamc@424: newline, adamc@424: string "int uw_db_begin(uw_context ctx) { return 0; };", adamc@424: newline, adamc@424: string "int uw_db_commit(uw_context ctx) { return 0; };", adamc@424: newline, adamc@424: string "int uw_db_rollback(uw_context ctx) { return 0; };", adamc@684: newline, adamc@684: string "void uw_expunger(uw_context ctx, uw_Basis_client cli) { };", adamc@687: newline, adamc@687: string "void uw_initializer(uw_context ctx) { };", adamc@376: newline]] adamc@29: end adamc@29: adamc@274: fun p_sql env (ds, _) = adamc@274: let adamc@274: val (pps, _) = ListUtil.foldlMap adamc@274: (fn (dAll as (d, _), env) => adamc@274: let adamc@274: val pp = case d of adamc@707: DTable (s, xts, pk, csts) => adamc@274: box [string "CREATE TABLE ", adamc@274: string s, adamc@274: string "(", adamc@274: p_list (fn (x, t) => adamc@311: box [string "uw_", adamc@275: string (CharVector.map Char.toLower x), adamc@274: space, adamc@467: p_sqltype env (t, ErrorMsg.dummySpan)]) xts, adamc@707: case (pk, csts) of adamc@707: ("", []) => box [] adamc@707: | _ => string ",", adamc@704: cut, adamc@707: case pk of adamc@707: "" => box [] adamc@707: | _ => box [string "PRIMARY", adamc@707: space, adamc@707: string "KEY", adamc@707: space, adamc@707: string "(", adamc@707: string pk, adamc@707: string ")", adamc@707: case csts of adamc@707: [] => box [] adamc@707: | _ => string ",", adamc@707: newline], adamc@704: p_list_sep (box [string ",", newline]) adamc@704: (fn (x, c) => adamc@704: box [string "CONSTRAINT", adamc@704: space, adamc@704: string s, adamc@704: string "_", adamc@704: string x, adamc@704: space, adamc@704: string c]) csts, adamc@704: newline, adamc@274: string ");", adamc@274: newline, adamc@274: newline] adamc@338: | DSequence s => adamc@338: box [string "CREATE SEQUENCE ", adamc@338: string s, adamc@338: string ";", adamc@338: newline, adamc@338: newline] adamc@274: | _ => box [] adamc@274: in adamc@274: (pp, E.declBinds env dAll) adamc@274: end) adamc@274: env ds adamc@274: in adamc@274: box pps adamc@274: end adamc@274: adamc@29: end