adamc@29: (* Copyright (c) 2008, 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@29: fun p_typ' par env (t, loc) = adamc@29: case t of adamc@269: TFun (t1, t2) => parenIf par (box [p_typ' true env t2, adamc@109: space, adamc@109: string "(*)", adamc@109: space, adamc@109: string "(", adamc@109: p_typ env t1, adamc@109: string ")"]) adamc@29: | TRecord i => box [string "struct", adamc@29: space, adamc@29: string "__lws_", adamc@29: string (Int.toString i)] adamc@188: | TDatatype (Enum, n, _) => adamc@188: (box [string "enum", adamc@188: space, adamc@188: string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)] adamc@188: handle CjrEnv.UnboundNamed _ => string ("__lwd_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@166: string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] adamc@166: handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) adamc@53: | TFfi (m, x) => box [string "lw_", string m, string "_", string x] adamc@288: | TOption t => adamc@288: (case #1 t of adamc@288: TDatatype _ => p_typ' par env t adamc@288: | TFfi ("Basis", "string") => p_typ' par env t adamc@288: | _ => box [p_typ' par env t, adamc@288: string "*"]) adamc@29: adamc@29: and p_typ env = p_typ' false env adamc@29: adamc@29: fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1)) adamc@29: handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) adamc@29: adamc@109: fun p_enamed env n = adamc@109: string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n) adamc@109: handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n) adamc@109: adamc@182: fun p_con_named env n = adamc@182: string ("__lwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n) adamc@182: handle CjrEnv.UnboundNamed _ => string ("__lwc_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@182: string "__lwr_", adamc@182: string 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@186: | PConFfi {mod = m, con, ...} => string ("lw_" ^ m ^ "_" ^ 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@182: (box [string "__lwr_", adamc@182: string 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@196: ("lw_" ^ x, to) adamc@182: end adamc@188: | PConFfi {mod = m, con, arg, ...} => adamc@188: ("lw_" ^ m ^ "_" ^ 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@198: case #1 t of adamc@198: TDatatype _ => box [string "disc", adamc@198: string (Int.toString depth)] adamc@199: | TFfi ("Basis", "string") => box [string "disc", adamc@199: string (Int.toString depth)] adamc@198: | _ => box [string "*disc", adamc@198: 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@196: string ".__lwf_", adamc@182: string 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@288: case #1 t of adamc@288: TDatatype _ => box [string "disc", adamc@288: string (Int.toString depth)] adamc@288: | TFfi ("Basis", "string") => box [string "disc", adamc@288: string (Int.toString depth)] adamc@288: | _ => box [string "*disc", adamc@288: 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@185: ("__lwd_" ^ dx ^ "_" ^ Int.toString dn, adamc@196: "__lwc_" ^ x ^ "_" ^ Int.toString n, adamc@196: "lw_" ^ x) adamc@185: end adamc@186: | PConFfi {mod = m, datatyp, con, ...} => adamc@185: ("lw_" ^ m ^ "_" ^ datatyp, adamc@196: "lw_" ^ m ^ "_" ^ con, adamc@196: "lw_" ^ con) adamc@185: adamc@278: fun p_unsql env (tAll as (t, loc)) e = adamc@278: case t of adamc@295: TFfi ("Basis", "int") => box [string "lw_Basis_stringToInt_error(ctx, ", e, string ")"] adamc@295: | TFfi ("Basis", "float") => box [string "lw_Basis_stringToFloat_error(ctx, ", e, string ")"] adamc@278: | TFfi ("Basis", "string") => box [string "lw_Basis_strdup(ctx, ", e, string ")"] adamc@295: | TFfi ("Basis", "bool") => box [string "lw_Basis_stringToBool_error(ctx, ", e, string ")"] 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@282: datatype sql_type = adamc@282: Int adamc@282: | Float adamc@282: | String adamc@282: | Bool adamc@282: adamc@282: fun p_sql_type t = adamc@282: string (case t of adamc@282: Int => "lw_Basis_int" adamc@282: | Float => "lw_Basis_float" adamc@282: | String => "lw_Basis_string" adamc@282: | Bool => "lw_Basis_bool") 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@282: adamc@282: | _ => raise Fail "CjrPrint: getPargs" adamc@282: adamc@282: fun p_ensql t e = adamc@282: case t of adamc@295: Int => box [string "lw_Basis_attrifyInt(ctx, ", e, string ")"] adamc@295: | Float => box [string "lw_Basis_attrifyFloat(ctx, ", e, string ")"] adamc@282: | String => e adamc@295: | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] adamc@282: adamc@282: fun p_ensql_len t e = adamc@282: case t of adamc@282: Int => string "sizeof(lw_Basis_int)" adamc@282: | Float => string "sizeof(lw_Basis_float)" adamc@282: | String => box [string "strlen(", e, string ")"] adamc@282: | Bool => string "sizeof(lw_Basis_bool)" adamc@282: 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@198: case #1 t of adamc@198: TDatatype _ => p_exp' par env e adamc@199: | TFfi ("Basis", "string") => p_exp' par env e adamc@198: | _ => box [string "({", adamc@198: newline, adamc@198: p_typ env t, adamc@198: space, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: space, adamc@198: string "lw_malloc(ctx, sizeof(", adamc@198: p_typ env t, adamc@198: string "));", adamc@198: newline, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: p_exp' par env e, adamc@198: string ";", adamc@198: newline, adamc@198: string "tmp;", adamc@198: newline, adamc@198: 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@185: string "lw_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@290: (case #1 t of adamc@290: TDatatype _ => p_exp' par env e adamc@290: | TFfi ("Basis", "string") => p_exp' par env e adamc@290: | _ => box [string "({", adamc@290: newline, adamc@290: p_typ env t, adamc@290: space, adamc@290: string "*tmp", adamc@290: space, adamc@290: string "=", adamc@290: space, adamc@290: string "lw_malloc(ctx, sizeof(", adamc@290: p_typ env t, adamc@290: string "));", adamc@290: newline, adamc@290: string "*tmp", adamc@290: space, adamc@290: string "=", adamc@290: p_exp' par env e, adamc@290: string ";", adamc@290: newline, adamc@290: string "tmp;", adamc@290: newline, adamc@290: string "})"]) adamc@109: adamc@53: | EFfi (m, x) => box [string "lw_", string m, string "_", string 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@292: string "lw_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@53: | EFfiApp (m, x, es) => box [string "lw_", adamc@53: string m, adamc@53: string "_", adamc@53: string x, adamc@117: string "(ctx, ", adamc@53: p_list (p_exp env) es, adamc@53: string ")"] adamc@129: | EApp (e1, e2) => adamc@129: let adamc@129: fun unravel (f, acc) = adamc@129: case #1 f of adamc@129: EApp (f', arg) => unravel (f', arg :: acc) adamc@129: | _ => (f, acc) adamc@129: adamc@129: val (f, args) = unravel (e1, [e2]) adamc@129: in adamc@129: parenIf par (box [p_exp' true env e1, adamc@129: string "(ctx,", adamc@129: space, adamc@129: p_list_sep (box [string ",", space]) (p_exp env) args, adamc@129: string ")"]) adamc@129: end adamc@29: adamc@29: | ERecord (i, xes) => box [string "({", adamc@29: space, adamc@29: string "struct", adamc@29: space, adamc@29: string ("__lws_" ^ 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@182: string ".__lwf_", adamc@29: string 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@182: string "lw_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@117: | EWrite e => box [string "(lw_write(ctx, ", adamc@102: p_exp env e, adamc@102: string "), lw_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@272: string "__lwr_", adamc@272: string 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@278: val exps = map (fn (x, t) => ("__lwf_" ^ x, t)) exps adamc@278: val tables = ListUtil.mapConcat (fn (x, xts) => adamc@278: map (fn (x', t) => ("__lwf_" ^ x ^ ".__lwf_" ^ x', t)) xts) adamc@278: tables adamc@278: adamc@278: val outputs = exps @ tables adamc@278: in adamc@278: box [string "({", adamc@278: newline, adamc@278: string "PGconn *conn = lw_get_db(ctx);", adamc@278: newline, 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@278: string "int n, i;", adamc@278: newline, adamc@278: p_typ env state, adamc@278: space, adamc@278: string "acc", adamc@278: space, adamc@278: string "=", adamc@278: space, adamc@278: p_exp env initial, adamc@278: string ";", adamc@278: newline, adamc@282: string "PGresult *res = ", adamc@282: case prepared of adamc@295: NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" adamc@282: | SOME n => box [string "PQexecPrepared(conn, \"lw", 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@278: string "if (res == NULL) lw_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@278: string "lw_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@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@278: string "__lws_", adamc@278: string (Int.toString rnum), adamc@278: space, adamc@278: string "__lwr_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@278: string "__lwr_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@278: box [string "__lwr_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@278: p_unsql env t adamc@278: (box [string "PQgetvalue(res, i, ", adamc@278: string (Int.toString i), adamc@278: string ")"]), 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@278: string "PQclear(res);", adamc@278: newline, adamc@278: string "acc;", adamc@278: newline, adamc@278: string "})"] adamc@278: end adamc@106: 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@129: string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), adamc@129: string "(", adamc@129: p_list_sep (box [string ",", space]) (fn x => x) adamc@129: (string "lw_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@129: box[string "return(", adamc@129: p_exp env' e, adamc@129: 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@196: string ("__lws_" ^ 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@196: string "__lwf_", adamc@196: string 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@188: string ("__lwe_" ^ x ^ "_" ^ Int.toString n), adamc@188: space, adamc@188: string "{", adamc@188: space, adamc@188: p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ 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@165: string ("__lwe_" ^ x ^ "_" ^ Int.toString n), adamc@165: space, adamc@165: string "{", adamc@165: space, adamc@165: p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ 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@167: string ("__lwd_" ^ x ^ "_" ^ Int.toString n), adamc@165: space, adamc@165: string "{", adamc@165: newline, adamc@165: string "enum", adamc@165: space, adamc@165: string ("__lwe_" ^ 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@196: string ("lw_" ^ 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@29: string ("__lwn_" ^ 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@129: string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), adamc@129: string "(lw_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@273: | DTable (x, _) => box [string "/* SQL table ", adamc@273: string x, adamc@273: string " */", adamc@273: newline] adamc@275: | DDatabase s => box [string "static void lw_db_validate(lw_context);", adamc@272: newline, adamc@282: string "static void lw_db_prepare(lw_context);", adamc@282: newline, adamc@275: newline, adamc@275: string "void lw_db_init(lw_context ctx) {", adamc@273: newline, adamc@272: string "PGconn *conn = PQconnectdb(\"", adamc@272: string (String.toString s), adamc@272: string "\");", adamc@272: newline, adamc@272: string "if (conn == NULL) lw_error(ctx, BOUNDED_RETRY, ", adamc@272: string "\"libpq can't allocate a connection.\");", adamc@272: newline, adamc@272: string "if (PQstatus(conn) != CONNECTION_OK) {", adamc@272: newline, adamc@272: box [string "char msg[1024];", adamc@272: newline, adamc@272: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@272: newline, adamc@272: string "msg[1023] = 0;", adamc@272: newline, adamc@272: string "PQfinish(conn);", adamc@272: newline, adamc@272: string "lw_error(ctx, BOUNDED_RETRY, ", adamc@272: string "\"Connection to Postgres server failed: %s\", msg);"], adamc@272: newline, adamc@272: string "}", adamc@272: newline, adamc@272: string "lw_set_db(ctx, conn);", adamc@272: newline, adamc@275: string "lw_db_validate(ctx);", adamc@275: newline, adamc@282: string "lw_db_prepare(ctx);", adamc@282: newline, adamc@272: string "}", adamc@272: newline, adamc@272: newline, adamc@272: string "void lw_db_close(lw_context ctx) {", adamc@272: newline, adamc@272: string "PQfinish(lw_get_db(ctx));", adamc@272: newline, adamc@272: string "}", adamc@272: newline] adamc@29: adamc@282: | DPreparedStatements ss => adamc@282: box [string "static void lw_db_prepare(lw_context ctx) {", adamc@282: newline, adamc@282: string "PGconn *conn = lw_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@282: box [string "res = PQprepare(conn, \"lw", 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@282: string "lw_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@144: datatype 'a search = adamc@144: Found of 'a adamc@144: | NotFound adamc@144: | Error adamc@120: adamc@275: 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@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@275: fun p_sqltype env t = string (p_sqltype' env t) adamc@101: adamc@101: fun p_file env (ds, ps) = adamc@29: let adamc@101: val (pds, env) = ListUtil.foldlMap (fn (d, env) => adamc@31: (p_decl env d, adamc@31: E.declBinds env d)) adamc@101: env ds adamc@144: adamc@144: val fields = foldl (fn ((ek, _, _, ts), fields) => adamc@144: case ek of adamc@144: Core.Link => 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@186: fun capitalize s = adamc@186: if s = "" then adamc@186: "" adamc@186: else adamc@186: str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@186: adamc@144: fun unurlify (t, loc) = adamc@144: case t of adamc@186: TFfi (m, t) => string ("lw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") adamc@144: adamc@144: | TRecord 0 => string "lw_unit_v" adamc@144: | TRecord i => adamc@144: let adamc@144: val xts = E.lookupStruct env i adamc@144: in adamc@144: box [string "({", adamc@144: newline, adamc@144: box (map (fn (x, t) => adamc@144: box [p_typ env t, adamc@144: space, adamc@144: string x, adamc@144: space, adamc@144: string "=", adamc@144: space, adamc@144: unurlify t, adamc@144: string ";", adamc@144: newline]) xts), adamc@144: string "struct", adamc@144: space, adamc@144: string "__lws_", adamc@144: string (Int.toString i), adamc@144: space, adamc@181: string "tmp", adamc@144: space, adamc@144: string "=", adamc@144: space, adamc@144: string "{", adamc@144: space, adamc@144: p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts, adamc@144: space, adamc@144: string "};", adamc@144: newline, adamc@181: string "tmp;", adamc@144: newline, adamc@144: string "})"] adamc@144: end adamc@144: adamc@188: | TDatatype (Enum, i, _) => adamc@188: let adamc@188: val (x, xncs) = E.lookupDatatype env i adamc@188: adamc@188: fun doEm xncs = adamc@188: case xncs of adamc@188: [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_" adamc@188: ^ x ^ "_" ^ Int.toString i ^ ")0)") adamc@188: | (x', n, to) :: rest => adamc@188: box [string "((!strncmp(request, \"", adamc@188: string x', adamc@188: string "\", ", adamc@188: string (Int.toString (size x')), adamc@188: string ") && (request[", adamc@188: string (Int.toString (size x')), adamc@188: string "] == 0 || request[", adamc@188: string (Int.toString (size x')), adamc@188: string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n), adamc@188: space, adamc@188: string ":", adamc@188: space, adamc@188: doEm rest, adamc@188: string ")"] adamc@188: in adamc@188: doEm xncs adamc@188: end adamc@188: adamc@198: | TDatatype (Option, i, xncs) => adamc@198: let adamc@198: val (x, _) = E.lookupDatatype env i adamc@198: adamc@198: val (no_arg, has_arg, t) = adamc@198: case !xncs of adamc@198: [(no_arg, _, NONE), (has_arg, _, SOME t)] => adamc@198: (no_arg, has_arg, t) adamc@198: | [(has_arg, _, SOME t), (no_arg, _, NONE)] => adamc@198: (no_arg, has_arg, t) adamc@198: | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" adamc@198: in adamc@198: box [string "(request[0] == '/' ? ++request : request,", adamc@198: newline, adamc@198: string "((!strncmp(request, \"", adamc@198: string no_arg, adamc@198: string "\", ", adamc@198: string (Int.toString (size no_arg)), adamc@198: string ") && (request[", adamc@198: string (Int.toString (size no_arg)), adamc@198: string "] == 0 || request[", adamc@198: string (Int.toString (size no_arg)), adamc@198: string "] == '/')) ? (request", adamc@198: space, adamc@198: string "+=", adamc@198: space, adamc@198: string (Int.toString (size no_arg)), adamc@198: string ", NULL) : ((!strncmp(request, \"", adamc@198: string has_arg, adamc@198: string "\", ", adamc@198: string (Int.toString (size has_arg)), adamc@198: string ") && (request[", adamc@198: string (Int.toString (size has_arg)), adamc@198: string "] == 0 || request[", adamc@198: string (Int.toString (size has_arg)), adamc@198: string "] == '/')) ? (request", adamc@198: space, adamc@198: string "+=", adamc@198: space, adamc@198: string (Int.toString (size has_arg)), adamc@200: string ", (request[0] == '/' ? ++request : NULL), ", adamc@200: newline, adamc@198: adamc@198: case #1 t of adamc@198: TDatatype _ => unurlify t adamc@199: | TFfi ("Basis", "string") => unurlify t adamc@198: | _ => box [string "({", adamc@198: newline, adamc@198: p_typ env t, adamc@198: space, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: space, adamc@198: string "lw_malloc(ctx, sizeof(", adamc@198: p_typ env t, adamc@198: string "));", adamc@198: newline, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: space, adamc@198: unurlify t, adamc@198: string ";", adamc@198: newline, adamc@198: string "tmp;", adamc@198: newline, adamc@198: string "})"], adamc@198: string ")", adamc@198: newline, adamc@198: string ":", adamc@198: space, adamc@198: string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")] adamc@198: end adamc@198: adamc@188: | TDatatype (Default, i, _) => adamc@166: let adamc@166: val (x, xncs) = E.lookupDatatype env i adamc@166: adamc@166: fun doEm xncs = adamc@166: case xncs of adamc@167: [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)") adamc@167: | (x', n, to) :: rest => adamc@167: box [string "((!strncmp(request, \"", adamc@167: string x', adamc@167: string "\", ", adamc@167: string (Int.toString (size x')), adamc@167: string ") && (request[", adamc@167: string (Int.toString (size x')), adamc@167: string "] == 0 || request[", adamc@167: string (Int.toString (size x')), adamc@167: string "] == '/')) ? ({", adamc@166: newline, adamc@167: string "struct", adamc@167: space, adamc@166: string ("__lwd_" ^ x ^ "_" ^ Int.toString i), adamc@166: space, adamc@181: string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_", adamc@167: string x, adamc@167: string "_", adamc@167: string (Int.toString i), adamc@167: string "));", adamc@166: newline, adamc@181: string "tmp->tag", adamc@166: space, adamc@166: string "=", adamc@166: space, adamc@167: string ("__lwc_" ^ x' ^ "_" ^ Int.toString n), adamc@166: string ";", adamc@166: newline, adamc@166: string "request", adamc@166: space, adamc@166: string "+=", adamc@166: space, adamc@167: string (Int.toString (size x')), adamc@166: string ";", adamc@166: newline, adamc@200: string "if (request[0] == '/') ++request;", adamc@200: newline, adamc@166: case to of adamc@166: NONE => box [] adamc@197: | SOME t => box [string "tmp->data.lw_", adamc@167: string x', adamc@166: space, adamc@166: string "=", adamc@166: space, adamc@166: unurlify t, adamc@166: string ";", adamc@166: newline], adamc@181: string "tmp;", adamc@166: newline, adamc@166: string "})", adamc@166: space, adamc@166: string ":", adamc@166: space, adamc@166: doEm rest, adamc@166: string ")"] adamc@166: in adamc@166: doEm xncs adamc@166: end adamc@166: adamc@144: | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; adamc@144: space) adamc@144: adamc@144: adamc@144: fun p_page (ek, s, n, ts) = adamc@144: let adamc@144: val (ts, defInputs, inputsVar) = adamc@144: case ek of adamc@144: Core.Link => (ts, 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@144: string "lw_input_", adamc@144: string 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@190: box [string "request = lw_get_", adamc@190: string f, adamc@190: string "input(ctx, ", adamc@144: string (Int.toString n), adamc@144: string ");", adamc@144: newline, adamc@144: string "if (request == NULL) {", adamc@144: newline, adamc@144: box [string "printf(\"Missing input ", adamc@144: string x, adamc@144: string "\\n\");", adamc@144: newline, adamc@144: string "exit(1);"], adamc@144: newline, adamc@144: string "}", adamc@144: newline, adamc@144: string "lw_input_", adamc@144: string x, adamc@144: space, adamc@144: string "=", adamc@144: space, adamc@144: unurlify t, adamc@144: string ";", adamc@144: newline] adamc@144: end) xts), adamc@144: string "struct __lws_", adamc@144: string (Int.toString i), adamc@144: space, adamc@144: string "lw_inputs", adamc@144: space, adamc@144: string "= {", adamc@144: newline, adamc@144: box (map (fn (x, _) => box [string "lw_input_", adamc@144: string x, adamc@144: string ",", adamc@144: newline]) xts), adamc@144: string "};", adamc@144: newline], adamc@144: box [string ",", adamc@144: space, adamc@144: string "lw_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@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@144: unurlify t, adamc@144: string ";", adamc@144: newline]) ts), adamc@144: defInputs, 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@280: string ", lw_unit_v);", adamc@144: 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@275: val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts) adamc@275: | _ => NONE) ds adamc@275: adamc@275: val validate = adamc@275: box [string "static void lw_db_validate(lw_context ctx) {", adamc@275: newline, adamc@275: string "PGconn *conn = lw_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@275: val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" adamc@275: ^ s ^ "'" adamc@275: adamc@275: val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", adamc@275: s, adamc@275: "') AND (", adamc@275: String.concatWith " OR " adamc@275: (map (fn (x, t) => adamc@275: String.concat ["(attname = 'lw_", adamc@275: CharVector.map adamc@275: Char.toLower x, adamc@275: "' AND atttypid = (SELECT oid FROM pg_type", adamc@275: " WHERE typname = '", adamc@275: p_sqltype' env t, adamc@275: "'))"]) 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@275: s, adamc@275: "') AND attnum >= 0"] 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@275: string "lw_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@275: string "lw_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@275: string "lw_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@275: string "lw_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@275: string "lw_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@275: string "lw_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@275: string "lw_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@275: string "lw_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@275: string "lw_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@275: string "}"] 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@272: string "#include ", adamc@272: newline, adamc@144: newline, adamc@244: string "#include \"urweb.h\"", adamc@101: newline, adamc@101: newline, adamc@101: p_list_sep newline (fn x => x) pds, adamc@101: newline, adamc@144: string "int lw_inputs_len = ", adamc@144: string (Int.toString (SM.foldl Int.max 0 fnums + 1)), adamc@144: string ";", adamc@144: newline, adamc@144: newline, adamc@144: string "int lw_input_num(char *name) {", adamc@144: newline, adamc@144: makeSwitch (fnums, 0), adamc@144: string "}", adamc@144: newline, adamc@144: newline, adamc@117: string "void lw_handle(lw_context ctx, char *request) {", adamc@101: newline, adamc@101: p_list_sep newline (fn x => x) pds', adamc@101: newline, adamc@101: string "}", adamc@275: newline, adamc@275: newline, adamc@275: validate, adamc@101: 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@274: DTable (s, xts) => adamc@274: box [string "CREATE TABLE ", adamc@274: string s, adamc@274: string "(", adamc@274: p_list (fn (x, t) => adamc@274: box [string "lw_", adamc@275: string (CharVector.map Char.toLower x), adamc@274: space, adamc@274: p_sqltype env t, adamc@274: space, adamc@274: string "NOT", adamc@274: space, adamc@274: string "NULL"]) xts, adamc@274: string ");", adamc@274: newline, adamc@274: 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