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 "<FUNCTION>")
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@757:       | TList (_, i) => box [string "struct",
adamc@757:                              space,
adamc@757:                              string "__uws_",
adamc@757:                              string (Int.toString i),
adamc@757:                              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@757: fun p_pat (env, exit, depth) (p, loc) =
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@743: fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen =
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@737:             box [string "uw_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@743:       | TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, ",
adamc@743:                                        e,
adamc@743:                                        string ", ",
adamc@743:                                        eLen,
adamc@743:                                        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@747:         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@747:         box [string "(PQgetisnull(res, i, ",
adamc@747:              string (Int.toString i),
adamc@747:              string ") ? ",
adamc@747:              box [string "({",
adamc@747:                   p_typ env tAll,
adamc@747:                   space,
adamc@747:                   string "tmp;",
adamc@747:                   newline,
adamc@747:                   string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
adamc@747:                   string (Int.toString i),
adamc@747:                   string "\");",
adamc@747:                   newline,
adamc@747:                   string "tmp;",
adamc@747:                   newline,
adamc@747:                   string "})"],
adamc@747:              string " : ",
adamc@747:              p_unsql wontLeakStrings env tAll
adamc@747:                      (box [string "PQgetvalue(res, i, ",
adamc@747:                            string (Int.toString i),
adamc@747:                            string ")"])
adamc@747:                      (box [string "PQgetlength(res, i, ",
adamc@747:                            string (Int.toString i),
adamc@747:                            string ")"]),
adamc@747:              string ")"]
adamc@467: 
adamc@867: datatype sql_type = datatype Settings.sql_type
adamc@867: val isBlob = Settings.isBlob
adamc@737: 
adamc@739: fun isFile (t : typ) =
adamc@737:     case #1 t of
adamc@739:         TFfi ("Basis", "file") => true
adamc@737:       | _ => false
adamc@737: 
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@737:       | Blob => "uw_Basis_blob"
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@737:       | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)]
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@737:       | Blob => box [e, string ".data"]
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@743:                            p_ensql t (box [string "(*", e, string ")"]),
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@742:               | TFfi ("Basis", "blob") => allowHeapAllocated
adamc@324:               | TFfi _ => true
adamc@638:               | TOption t => allowHeapAllocated andalso nl ok t
adamc@757:               | TList (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@758:               | TList (t', i) =>
adamc@758:                 if IS.member (rf, i) then
adamc@758:                     box [string "unurlify_list_",
adamc@758:                          string (Int.toString i),
adamc@758:                          string "()"]
adamc@758:                 else
adamc@758:                     let
adamc@758:                         val rf = IS.add (rf, i)
adamc@758:                     in
adamc@758:                         box [string "({",
adamc@758:                              space,
adamc@758:                              p_typ env (t, loc),
adamc@758:                              space,
adamc@758:                              string "unurlify_list_",
adamc@758:                              string (Int.toString i),
adamc@758:                              string "(void) {",
adamc@758:                              newline,
adamc@758:                              box [string "return (request[0] == '/' ? ++request : request,",
adamc@758:                                   newline,
adamc@758:                                   string "((!strncmp(request, \"Nil\", 3) && (request[3] == 0 ",
adamc@758:                                   string "|| request[3] == '/')) ? (request",
adamc@758:                                   space,
adamc@758:                                   string "+=",
adamc@758:                                   space,
adamc@758:                                   string "3, NULL) : ((!strncmp(request, \"Cons\", 4) && (request[4] == 0 ",
adamc@758:                                   string "|| request[4] == '/')) ? (request",
adamc@758:                                   space,
adamc@758:                                   string "+=",
adamc@758:                                   space,
adamc@758:                                   string "4, (request[0] == '/' ? ++request : NULL), ",
adamc@758:                                   newline,
adamc@758:                                   
adamc@758:                                   string "({",
adamc@758:                                   newline,
adamc@758:                                   p_typ env (t, loc),
adamc@758:                                   space,
adamc@758:                                   string "tmp",
adamc@758:                                   space,
adamc@758:                                   string "=",
adamc@758:                                   space,
adamc@758:                                   string "uw_malloc(ctx, sizeof(struct __uws_",
adamc@758:                                   string (Int.toString i),
adamc@758:                                   string "));",
adamc@758:                                   newline,
adamc@758:                                   string "*tmp",
adamc@758:                                   space,
adamc@758:                                   string "=",
adamc@758:                                   space,
adamc@758:                                   unurlify' rf (TRecord i),
adamc@758:                                   string ";",
adamc@758:                                   newline,
adamc@758:                                   string "tmp;",
adamc@758:                                   newline,
adamc@758:                                   string "})",
adamc@758:                                   string ")",
adamc@758:                                   newline,
adamc@758:                                   string ":",
adamc@758:                                   space,
adamc@758:                                   string ("(uw_error(ctx, FATAL, \"Error unurlifying list\"), NULL))));"),
adamc@758:                                   newline],
adamc@758:                              string "}",
adamc@758:                              newline,
adamc@758:                              newline,
adamc@758: 
adamc@758:                              string "unurlify_list_",
adamc@758:                              string (Int.toString i),
adamc@758:                              string "();",
adamc@758:                              newline,
adamc@758:                              string "})"]
adamc@758:                     end
adamc@758: 
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@867: fun sql_type_in env (tAll as (t, loc)) =
adamc@867:     case t of
adamc@867:         TFfi ("Basis", "int") => Int
adamc@867:       | TFfi ("Basis", "float") => Float
adamc@867:       | TFfi ("Basis", "string") => String
adamc@867:       | TFfi ("Basis", "bool") => Bool
adamc@867:       | TFfi ("Basis", "time") => Time
adamc@867:       | TFfi ("Basis", "blob") => Blob
adamc@867:       | TFfi ("Basis", "channel") => Channel
adamc@867:       | TFfi ("Basis", "client") => Client
adamc@867:       | TOption t' => Nullable (sql_type_in env t')
adamc@867:       | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
adamc@867:               Print.eprefaces' [("Type", p_typ env tAll)];
adamc@867:               Int)
adamc@867: 
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@741:       | EReturnBlob {blob, mimeType, t} =>
adamc@741:         box [string "({",
adamc@741:              newline,
adamc@741:              p_typ env t,
adamc@741:              space,
adamc@741:              string "tmp;",
adamc@741:              newline,
adamc@741:              string "uw_return_blob(ctx, ",
adamc@741:              p_exp env blob,
adamc@741:              string ", ",
adamc@741:              p_exp env mimeType,
adamc@741:              string ");",
adamc@741:              newline,
adamc@741:              string "tmp;",
adamc@741:              newline,
adamc@741:              string "})"]
adamc@476:       | EApp ((EError (e, (TFun (_, ran), _)), loc), _) =>
adamc@476:         p_exp env (EError (e, ran), loc)
adamc@741:       | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
adamc@741:         p_exp env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
adamc@476: 
adamc@765:       | EFfiApp (m, x, []) => box [string "uw_",
adamc@765:                                    p_ident m,
adamc@765:                                    string "_",
adamc@765:                                    p_ident x,
adamc@765:                                    string "(ctx)"]
adamc@765: 
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@867: 
adamc@867:             val inputs =
adamc@867:                 case prepared of
adamc@867:                     NONE => []
adamc@867:                   | SOME _ => getPargs query
adamc@867: 
adamc@867:             fun doCols p_getcol =
adamc@867:                 box [string "struct __uws_",
adamc@867:                      string (Int.toString rnum),
adamc@867:                      string " __uwr_r_",
adamc@867:                      string (Int.toString (E.countERels env)),
adamc@867:                      string ";",
adamc@867:                      newline,
adamc@867:                      p_typ env state,
adamc@867:                      space,
adamc@867:                      string "__uwr_acc_",
adamc@867:                      string (Int.toString (E.countERels env + 1)),
adamc@867:                      space,
adamc@867:                      string "=",
adamc@867:                      space,
adamc@867:                      string "acc;",
adamc@867:                      newline,
adamc@867:                      newline,
adamc@867:                      p_list_sepi (box []) (fn i =>
adamc@867:                                            fn (proj, t) =>
adamc@867:                                               box [string "__uwr_r_",
adamc@867:                                                    string (Int.toString (E.countERels env)),
adamc@867:                                                    string ".",
adamc@867:                                                    string proj,
adamc@867:                                                    space,
adamc@867:                                                    string "=",
adamc@867:                                                    space,
adamc@880:                                                    p_getcol {loc = loc,
adamc@880:                                                              wontLeakStrings = wontLeakStrings,
adamc@867:                                                              col = i,
adamc@867:                                                              typ = sql_type_in env t},
adamc@867:                                                    string ";",
adamc@867:                                                    newline]) outputs,
adamc@867:                      newline,
adamc@867:                      newline,
adamc@867: 
adamc@867:                      string "acc",
adamc@867:                      space,
adamc@867:                      string "=",
adamc@867:                      space,
adamc@867:                      p_exp (E.pushERel
adamc@867:                                 (E.pushERel env "r" (TRecord rnum, loc))
adamc@867:                                 "acc" state) 
adamc@867:                            body,
adamc@867:                      string ";",
adamc@867:                      newline]
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@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@867:                  string "int dummy = (uw_begin_region(ctx), 0);",
adamc@640:                  newline,
adamc@640:                  
adamc@282:                  case prepared of
adamc@867:                      NONE =>
adamc@867:                      box [string "char *query = ",
adamc@867:                           p_exp env query,
adamc@867:                           string ";",
adamc@867:                           newline,
adamc@867:                           newline,
adamc@282: 
adamc@867:                           #query (Settings.currentDbms ())
adamc@867:                                  {loc = loc,
adamc@873:                                   cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@867:                                   doCols = doCols}]
adamc@879:                    | SOME {id, query, nested} =>
adamc@867:                      box [p_list_sepi newline
adamc@867:                                       (fn i => fn (e, t) =>
adamc@867:                                                   box [p_sql_type t,
adamc@867:                                                        space,
adamc@867:                                                        string "arg",
adamc@867:                                                        string (Int.toString (i + 1)),
adamc@867:                                                        space,
adamc@867:                                                        string "=",
adamc@867:                                                        space,
adamc@867:                                                        p_exp env e,
adamc@867:                                                        string ";"])
adamc@867:                                       inputs,
adamc@867:                           newline,
adamc@867:                           newline,
adamc@640: 
adamc@867:                           #queryPrepared (Settings.currentDbms ())
adamc@867:                                          {loc = loc,
adamc@867:                                           id = id,
adamc@867:                                           query = query,
adamc@867:                                           inputs = map #2 inputs,
adamc@873:                                           cols = map (fn (_, t) => sql_type_in env t) outputs,
adamc@879:                                           doCols = doCols,
adamc@879:                                           nested = nested}],
adamc@278:                  newline,
adamc@277: 
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@307:              case prepared of
adamc@307:                  NONE => box [string "char *dml = ",
adamc@307:                               p_exp env dml,
adamc@307:                               string ";",
adamc@868:                               newline,
adamc@868:                               newline,
adamc@868:                               #dml (Settings.currentDbms ()) loc]
adamc@879:                | SOME {id, dml = dml'} =>
adamc@307:                  let
adamc@868:                      val inputs = 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@868:                                       inputs,
adamc@307:                           newline,
adamc@307:                           newline,
adamc@307: 
adamc@868:                           #dmlPrepared (Settings.currentDbms ()) {loc = loc,
adamc@868:                                                                   id = id,
adamc@868:                                                                   dml = dml',
adamc@868:                                                                   inputs = map #2 inputs}]
adamc@307:                  end,
adamc@307:              newline,
adamc@307:              newline,
adamc@307: 
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@878:         box [string "({",
adamc@878:              newline,
adamc@878:              string "uw_Basis_int n;",
adamc@878:              newline,
adamc@869: 
adamc@878:              case prepared of
adamc@878:                  NONE => #nextval (Settings.currentDbms ()) {loc = loc,
adamc@878:                                                              seqE = p_exp env seq,
adamc@878:                                                              seqName = case #1 seq of
adamc@878:                                                                            EPrim (Prim.String s) => SOME s
adamc@878:                                                                          | _ => NONE}
adamc@879:                | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
adamc@878:                                                                                  id = id,
adamc@878:                                                                                  query = query},
adamc@878:              newline,
adamc@878:              newline,
adamc@869: 
adamc@878:              string "n;",
adamc@878:              newline,
adamc@878:              string "})"]
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@737:                  string "uw_Basis_string request = uw_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@809:       | DDatatype dts =>
adamc@165:         let
adamc@809:             val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) =>
adamc@809:                                              dk1 = Enum andalso dk2 <> Enum) dts
adamc@809: 
adamc@809:             fun p_one (Enum, x, n, xncs) =
adamc@809:                 box [string "enum",
adamc@809:                      space,
adamc@809:                      string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809:                      space,
adamc@809:                      string "{",
adamc@809:                      space,
adamc@809:                      p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adamc@809:                                                               string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
adamc@809:                      space,
adamc@809:                      string "};"]
adamc@809:               | p_one (Option, _, _, _) = box []
adamc@809:               | p_one (Default, x, n, xncs) =
adamc@809:                 let
adamc@809:                     val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@809:                                                      | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@809:                 in
adamc@809:                     box [string "enum",
adamc@809:                          space,
adamc@809:                          string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809:                          space,
adamc@809:                          string "{",
adamc@809:                          space,
adamc@809:                          p_list_sep (box [string ",", space]) (fn (x, n, _) =>
adamc@809:                                                                   string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n))
adamc@809:                                     xncs,
adamc@809:                          space,
adamc@809:                          string "};",
adamc@809:                          newline,
adamc@809:                          newline,
adamc@809:                          string "struct",
adamc@809:                          space,
adamc@809:                          string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809:                          space,
adamc@809:                          string "{",
adamc@809:                          newline,
adamc@809:                          string "enum",
adamc@809:                          space,
adamc@809:                          string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
adamc@809:                          space,
adamc@809:                          string "tag;",
adamc@809:                          newline,
adamc@809:                          box (case xncsArgs of
adamc@809:                                   [] => []
adamc@809:                                 | _ => [string "union",
adamc@809:                                         space,
adamc@809:                                         string "{",
adamc@809:                                         newline,
adamc@809:                                         p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@809:                                                                                  space,
adamc@809:                                                                                  string ("uw_" ^ ident x),
adamc@809:                                                                                  string ";"]) xncsArgs,
adamc@809:                                         newline,
adamc@809:                                         string "}",
adamc@809:                                         space,
adamc@809:                                         string "data;",
adamc@809:                                         newline]),
adamc@809:                          string "};"]
adamc@809:                 end
adamc@165:         in
adamc@809:             p_list_sep (box []) p_one dts
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@754:       | DView (x, _, s) => box [string "/* SQL view ",
adamc@754:                                 string x,
adamc@754:                                 space,
adamc@754:                                 string "AS",
adamc@754:                                 space,
adamc@754:                                 string s,
adamc@754:                                 space,
adamc@754:                                 string " */",
adamc@754:                                 newline]
adamc@870:       | DDatabase _ => box []
adamc@870:       | DPreparedStatements _ => box []
adamc@282: 
adamc@569:       | DJavaScript s => box [string "static char jslib[] = \"",
adamc@569:                               string (String.toString s),
adamc@569:                               string "\";"]
adamc@725:       | DCookie s => box [string "/*",
adamc@725:                           space,
adamc@725:                           string "cookie",
adamc@725:                           space,
adamc@725:                           string s,
adamc@725:                           space,
adamc@725:                           string "*/"]
adamc@720:       | DStyle s => box [string "/*",
adamc@720:                          space,
adamc@720:                          string "style",
adamc@720:                          space,
adamc@720:                          string s,
adamc@720:                          space,
adamc@720:                          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@737:       | TFfi ("Basis", "blob") => "bytea"
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@734: fun sigName fields =
adamc@734:     let
adamc@734:         fun inFields s = List.exists (fn (s', _) => s' = s) fields
adamc@734: 
adamc@734:         fun getSigName n =
adamc@734:             let
adamc@734:                 val s = "Sig" ^ Int.toString n
adamc@734:             in
adamc@734:                 if inFields s then
adamc@734:                     getSigName (n + 1)
adamc@734:                 else
adamc@734:                     s
adamc@734:             end
adamc@734:     in
adamc@734:         if inFields "Sig" then
adamc@734:             getSigName 0
adamc@734:         else
adamc@734:             "Sig"
adamc@734:     end
adamc@734: 
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@779:         fun flatFields always (t : typ) =
adamc@756:             case #1 t of
adamc@756:                 TRecord i =>
adamc@756:                 let
adamc@756:                     val xts = E.lookupStruct env i
adamc@756:                 in
adamc@779:                     SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts))
adamc@756:                 end
adamc@759:               | TList (_, i) =>
adamc@759:                 let
adamc@759:                     val ts = E.lookupStruct env i
adamc@759:                 in
adamc@759:                     case ts of
adamc@779:                         [("1", t'), ("2", _)] => flatFields [] t'
adamc@759:                       | _ => raise Fail "CjrPrint: Bad struct for TList"
adamc@759:                 end
adamc@756:               | _ => NONE
adamc@756: 
adamc@643:         val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
adamc@144:                                case ek of
adamc@735:                                    Link => fields
adamc@735:                                  | Rpc _ => fields
adamc@735:                                  | Action eff =>
adamc@280:                                    case List.nth (ts, length ts - 2) of
adamc@756:                                        (TRecord i, loc) =>
adamc@144:                                        let
adamc@144:                                            val xts = E.lookupStruct env i
adamc@779:                                            val extra = case eff of
adamc@779:                                                            ReadCookieWrite => [sigName xts]
adamc@779:                                                        | _ => []
adamc@144:                                        in
adamc@779:                                            case flatFields extra (TRecord i, loc) of
adamc@756:                                                NONE => raise Fail "CjrPrint: flatFields impossible"
adamc@756:                                              | SOME fields' => List.revAppend (fields', fields)
adamc@144:                                        end
adamc@144:                                      | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@756:                            [] ps
adamc@756: 
adamc@756:         val fields = foldl (fn (xts, fields) =>
adamc@756:                                let
adamc@756:                                    val xtsSet = SS.addList (SS.empty, xts)
adamc@756:                                in
adamc@756:                                    foldl (fn (x, fields) =>
adamc@756:                                              let
adamc@756:                                                  val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@756:                                              in
adamc@756:                                                  SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@756:                                                                                  xtsSet'))
adamc@756:                                              end) fields xts
adamc@756:                                end)
adamc@756:                            SM.empty fields
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@734:         val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
adamc@734: 
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@756:         fun getInput (x, t) =
adamc@756:             let
adamc@756:                 val n = case SM.find (fnums, x) of
adamc@759:                             NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums")
adamc@756:                           | SOME n => n
adamc@756: 
adamc@756:                 val f = case t of
adamc@756:                             (TFfi ("Basis", "bool"), _) => "optional_"
adamc@756:                           | _ => ""
adamc@756:             in
adamc@756:                 if isFile t then
adamc@756:                     box [string "uw_input_",
adamc@756:                          p_ident x,
adamc@756:                          space,
adamc@756:                          string "=",
adamc@756:                          space,
adamc@756:                          string "uw_get_file_input(ctx, ",
adamc@756:                          string (Int.toString n),
adamc@756:                          string ");",
adamc@756:                          newline]
adamc@756:                 else case #1 t of
adamc@756:                          TRecord i =>
adamc@756:                          let
adamc@756:                              val xts = E.lookupStruct env i
adamc@756:                          in
adamc@756:                              box [string "uw_enter_subform(ctx, ",
adamc@756:                                   string (Int.toString n),
adamc@756:                                   string ");",
adamc@756:                                   newline,
adamc@756:                                   string "uw_input_",
adamc@756:                                   p_ident x,
adamc@756:                                   space,
adamc@756:                                   string "=",
adamc@756:                                   space,
adamc@756:                                   string "({",
adamc@756:                                   box [p_typ env t,
adamc@756:                                        space,
adamc@756:                                        string "result;",
adamc@756:                                        newline,
adamc@756:                                        p_list_sep (box [])
adamc@756:                                                   (fn (x, t) =>
adamc@756:                                                       box [p_typ env t,
adamc@756:                                                            space,
adamc@756:                                                            string "uw_input_",
adamc@756:                                                            string x,
adamc@756:                                                            string ";",
adamc@756:                                                            newline])
adamc@756:                                                   xts,
adamc@756:                                        newline,
adamc@756:                                        p_list_sep (box []) (fn (x, t) =>
adamc@756:                                                                box [getInput (x, t),
adamc@756:                                                                     string "result.__uwf_",
adamc@756:                                                                     string x,
adamc@756:                                                                     space,
adamc@756:                                                                     string "=",
adamc@756:                                                                     space,
adamc@756:                                                                     string "uw_input_",
adamc@756:                                                                     string x,
adamc@756:                                                                     string ";",
adamc@756:                                                                     newline])
adamc@756:                                                   xts,
adamc@756:                                        newline,
adamc@756:                                        string "result;",
adamc@756:                                        newline],
adamc@756:                                   string "});",
adamc@756:                                   newline,
adamc@756:                                   string "uw_leave_subform(ctx);"]
adamc@756:                          end
adamc@759:                        | TList (t', i) =>
adamc@759:                          let
adamc@759:                              val xts = E.lookupStruct env i
adamc@759:                              val i' = case xts of
adamc@759:                                           [("1", (TRecord i', loc)), ("2", _)] => i'
adamc@759:                                         | _ => raise Fail "CjrPrint: Bad TList record [2]"
adamc@759:                              val xts = E.lookupStruct env i'
adamc@759:                          in
adamc@759:                              box [string "{",
adamc@759:                                   newline,
adamc@759:                                   string "int status;",
adamc@759:                                   newline,
adamc@759:                                   string "uw_input_",
adamc@759:                                   p_ident x,
adamc@759:                                   space,
adamc@759:                                   string "=",
adamc@759:                                   space,
adamc@759:                                   string "NULL;",
adamc@759:                                   newline,
adamc@759:                                   string "for (status = uw_enter_subforms(ctx, ",
adamc@759:                                   string (Int.toString n),
adamc@759:                                   string "); status; status = uw_next_entry(ctx)) {",
adamc@759:                                   newline,
adamc@759:                                   box [p_typ env t,
adamc@759:                                        space,
adamc@759:                                        string "result",
adamc@759:                                        space,
adamc@759:                                        string "=",
adamc@759:                                        space,
adamc@759:                                        string "uw_malloc(ctx, sizeof(struct __uws_",
adamc@759:                                        string (Int.toString i),
adamc@759:                                        string "));",
adamc@759:                                        newline,
adamc@759:                                        box [string "{",
adamc@759:                                             p_list_sep (box [])
adamc@759:                                                        (fn (x, t) =>
adamc@759:                                                            box [p_typ env t,
adamc@759:                                                                 space,
adamc@759:                                                                 string "uw_input_",
adamc@759:                                                                 string x,
adamc@759:                                                                 string ";",
adamc@759:                                                                 newline])
adamc@759:                                                        xts,
adamc@759:                                             newline,
adamc@759:                                             p_list_sep (box []) (fn (x, t) =>
adamc@759:                                                                     box [getInput (x, t),
adamc@759:                                                                          string "result->__uwf_1.__uwf_",
adamc@759:                                                                          string x,
adamc@759:                                                                          space,
adamc@759:                                                                          string "=",
adamc@759:                                                                          space,
adamc@759:                                                                          string "uw_input_",
adamc@759:                                                                          string x,
adamc@759:                                                                          string ";",
adamc@759:                                                                          newline])
adamc@759:                                                        xts,
adamc@759:                                             string "}",
adamc@759:                                             newline],
adamc@759:                                        newline,
adamc@759:                                        string "result->__uwf_2 = uw_input_",
adamc@759:                                        p_ident x,
adamc@759:                                        string ";",
adamc@759:                                        newline,
adamc@759:                                        string "uw_input_",
adamc@759:                                        p_ident x,
adamc@759:                                        string " = result;",
adamc@759:                                        newline],
adamc@759:                                   string "}}",
adamc@759:                                   newline]
adamc@759:                          end
adamc@756:                        | _ =>
adamc@756:                          box [string "request = uw_get_",
adamc@756:                               string f,
adamc@756:                               string "input(ctx, ",
adamc@756:                               string (Int.toString n),
adamc@756:                               string ");",
adamc@756:                               newline,
adamc@756:                               string "if (request == NULL)",
adamc@756:                               newline,
adamc@756:                               box [string "uw_error(ctx, FATAL, \"Missing input ",
adamc@756:                                    string x,
adamc@756:                                    string "\");"],
adamc@756:                               newline,
adamc@756:                               string "uw_input_",
adamc@756:                               p_ident x,
adamc@756:                               space,
adamc@756:                               string "=",
adamc@756:                               space,
adamc@756:                               unurlify env t,
adamc@756:                               string ";",
adamc@756:                               newline]
adamc@756:             end
adamc@756: 
adamc@643:         fun p_page (ek, s, n, ts, ran, side) =
adamc@144:             let
adamc@734:                 val (ts, defInputs, inputsVar, fields) =
adamc@144:                     case ek of
adamc@734:                         Core.Link => (List.take (ts, length ts - 1), string "", string "", NONE)
adamc@734:                       | Core.Rpc _ => (List.take (ts, length ts - 1), string "", string "", NONE)
adamc@731:                       | 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@756:                                       box (map getInput 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@734:                                       string "uw_inputs"],
adamc@734:                                  SOME xts)
adamc@144:                             end
adamc@144: 
adamc@144:                           | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@734: 
adamc@734:                 fun couldWrite ek =
adamc@734:                     case ek of
adamc@734:                         Link => false
adamc@735:                       | Action ef => ef = ReadCookieWrite
adamc@735:                       | Rpc ef => ef = ReadCookieWrite
adamc@863: 
adamc@863:                 val s =
adamc@863:                     case Settings.getUrlPrefix () of
adamc@863:                         "" => s
adamc@863:                       | "/" => s
adamc@863:                       | prefix =>
adamc@863:                         if size s > 0 andalso String.sub (s, 0) = #"/" then
adamc@863:                             prefix ^ String.extract (s, 1, NONE)
adamc@863:                         else
adamc@863:                             prefix ^ s
adamc@144:             in
adamc@735:                 box [string "if (!strncmp(request, \"",
adamc@735:                      string (String.toString s),
adamc@735:                      string "\", ",
adamc@735:                      string (Int.toString (size s)),
adamc@735:                      string ") && (request[",
adamc@735:                      string (Int.toString (size s)),
adamc@735:                      string "] == 0 || request[",
adamc@735:                      string (Int.toString (size s)),
adamc@735:                      string "] == '/')) {",
adamc@735:                      newline,
adamc@735:                      string "request += ",
adamc@735:                      string (Int.toString (size s)),
adamc@735:                      string ";",
adamc@735:                      newline,
adamc@735:                      string "if (*request == '/') ++request;",
adamc@735:                      newline,
adamc@735:                      if couldWrite ek then
adamc@734:                          box [string "{",
adamc@734:                               newline,
adamc@734:                               string "uw_Basis_string sig = ",
adamc@734:                               case fields of
adamc@734:                                   NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
adamc@734:                                 | SOME fields =>
adamc@734:                                   case SM.find (fnums, sigName fields) of
adamc@734:                                       NONE => raise Fail "CjrPrint: sig name wasn't assigned a number"
adamc@734:                                     | SOME inum =>
adamc@734:                                       string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"),
adamc@734:                               string ";",
adamc@734:                               newline,
adamc@734:                               string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");",
adamc@734:                               newline,
adamc@734:                               string "if (strcmp(sig, uw_cookie_sig(ctx)))",
adamc@734:                               newline,
adamc@734:                               box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");",
adamc@734:                                    newline],
adamc@734:                               string "}",
adamc@734:                               newline]
adamc@734:                      else
adamc@734:                          box [],
adamc@609:                      box (case ek of
adamc@731:                               Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
adamc@731:                                              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@804:                                     string "uw_write(ctx, begin_xhtml);",
adamc@643:                                     newline,
adamc@643:                                     string "uw_set_script_header(ctx, \"",
adamc@812:                                     let
adamc@812:                                         val scripts =
adamc@812:                                             case side of
adamc@693:                                                 ServerOnly => ""
adamc@693:                                               | _ => "<script src=\\\""
adamc@764:                                                      ^ OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
adamc@693:                                                                             file = "app.js"}
adamc@812:                                                      ^ "\\\"></script>\\n"
adamc@812: 
adamc@812:                                         val scripts = foldl (fn (x, scripts) =>
adamc@812:                                                                 scripts
adamc@812:                                                                 ^ "<script src=\\\"" ^ x ^ "\\\"></script>\\n")
adamc@812:                                                       scripts (Settings.getScripts ())
adamc@812:                                     in
adamc@812:                                         string scripts
adamc@812:                                     end,
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@764:                                     string (Settings.getUrlPrefix ()),
adamc@667:                                     string "\");",
adamc@609:                                     newline]),
adamc@736:                      string "uw_set_needs_sig(ctx, ",
adamc@736:                      string (if couldWrite ek then
adamc@736:                                  "1"
adamc@736:                              else
adamc@736:                                  "0"),
adamc@736:                      string ");",
adamc@736:                      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@731:                                    Core.Rpc _ => [p_typ env ran,
adamc@731:                                                   space,
adamc@731:                                                   string "it0",
adamc@731:                                                   space,
adamc@731:                                                   string "=",
adamc@731:                                                   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@731:                                    Core.Rpc _ => [urlify env ran]
adamc@609:                                  | _ => [string "uw_write(ctx, \"</html>\");",
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@870:         val hasDb = ref false
adamc@870:         val tables = ref []
adamc@872:         val views = ref []
adamc@870:         val sequences = ref []
adamc@870:         val dbstring = ref ""
adamc@870:         val expunge = ref 0
adamc@870:         val initialize = ref 0
adamc@870:         val prepped = ref []
adamc@275: 
adamc@870:         val () = app (fn d =>
adamc@870:                          case #1 d of
adamc@870:                              DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
adamc@870:                                                                                    dbstring := x;
adamc@870:                                                                                    expunge := y;
adamc@870:                                                                                    initialize := z)
adamc@870:                            | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
adamc@870:                                                                             (x, sql_type_in env t)) xts) :: !tables
adamc@872:                            | DView (s, xts, _) => views := (s, map (fn (x, t) =>
adamc@872:                                                                        (x, sql_type_in env t)) xts) :: !views
adamc@870:                            | DSequence s => sequences := s :: !sequences
adamc@870:                            | DPreparedStatements ss => prepped := ss
adamc@870:                            | _ => ()) ds
adamc@377: 
adamc@870:         val hasDb = !hasDb                                            
adamc@734: 
adamc@734:         val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
adamc@734: 
adamc@734:         val cookieCode = foldl (fn (cookie, acc) =>
adamc@734:                                    SOME (case acc of
adamc@734:                                              NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734:                                                              ^ cookie ^ "\"))")
adamc@734:                                            | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \""
adamc@734:                                                                       ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
adamc@734:                                                               acc,
adamc@734:                                                               string "))"]))
adamc@734:                          NONE cookies
adamc@770: 
adamc@770:         fun makeChecker (name, rules : Settings.rule list) =
adamc@770:             box [string "int ",
adamc@770:                  string name,
adamc@770:                  string "(const char *s) {",
adamc@770:                  newline,
adamc@770:                  box [p_list_sep (box [])
adamc@770:                       (fn rule =>
adamc@770:                           box [string "if (!str",
adamc@770:                                case #kind rule of
adamc@770:                                    Settings.Exact => box [string "cmp(s, \"",
adamc@770:                                                           string (String.toString (#pattern rule)),
adamc@770:                                                           string "\"))"]
adamc@770:                                  | Settings.Prefix => box [string "ncmp(s, \"",
adamc@770:                                                            string (String.toString (#pattern rule)),
adamc@770:                                                            string "\", ",
adamc@770:                                                            string (Int.toString (size (#pattern rule))),
adamc@770:                                                            string "))"],
adamc@770:                                string " return ",
adamc@770:                                string (case #action rule of
adamc@770:                                            Settings.Allow => "1"
adamc@770:                                          | Settings.Deny => "0"),
adamc@770:                                string ";",
adamc@770:                                newline]) rules,
adamc@770:                       string "return 0;",
adamc@770:                       newline],
adamc@770:                  string "}",
adamc@770:                  newline]
adamc@29:     in
adamc@144:         box [string "#include <stdio.h>",
adamc@144:              newline,
adamc@144:              string "#include <stdlib.h>",
adamc@144:              newline,
adamc@272:              string "#include <string.h>",
adamc@272:              newline,
adamc@390:              string "#include <math.h>",
adamc@390:              newline,
adamc@432:              if hasDb then
adamc@866:                  box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
adamc@432:                       newline]
adamc@432:              else
adamc@432:                  box [],
adamc@764:              p_list_sep (box []) (fn s => box [string "#include \"",
adamc@764:                                                string s,
adamc@764:                                                string "\"",
adamc@764:                                                newline]) (Settings.getHeaders ()),
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@804: 
adamc@870:              if hasDb then
adamc@870:                  #init (Settings.currentDbms ()) {dbstring = !dbstring,
adamc@870:                                                   prepared = !prepped,
adamc@870:                                                   tables = !tables,
adamc@872:                                                   views = !views,
adamc@870:                                                   sequences = !sequences}
adamc@870:              else
adamc@891:                  box [string "void uw_client_init(void) { };",
adamc@891:                       newline,
adamc@891:                       string "void uw_db_init(uw_context ctx) { };",
adamc@870:                       newline,
adamc@870:                       string "int uw_db_begin(uw_context ctx) { return 0; };",
adamc@870:                       newline,
adamc@870:                       string "int uw_db_commit(uw_context ctx) { return 0; };",
adamc@870:                       newline,
adamc@870:                       string "int uw_db_rollback(uw_context ctx) { return 0; };"],
adamc@870:              newline,
adamc@870:              newline,
adamc@870: 
adamc@863:              string "const char *uw_url_prefix = \"",
adamc@863:              string (Settings.getUrlPrefix ()),
adamc@863:              string "\";",
adamc@863:              newline,
adamc@863:              newline,
adamc@863: 
adamc@804:              string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
adamc@804:              newline,
adamc@804:              newline,
adamc@804: 
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@764:              string (Int.toString (Settings.getTimeout ())),
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@770: 
adamc@770:              makeChecker ("uw_check_url", Settings.getUrlRules ()),
adamc@770:              newline,
adamc@770: 
adamc@770:              makeChecker ("uw_check_mime", Settings.getMimeRules ()),
adamc@770:              newline,
adamc@734:              
adamc@734:              string "extern void uw_sign(const char *in, char *out);",
adamc@734:              newline,
adamc@734:              string "extern int uw_hash_blocksize;",
adamc@734:              newline,
adamc@734:              string "uw_Basis_string uw_cookie_sig(uw_context ctx) {",
adamc@734:              newline,
adamc@734:              box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);",
adamc@734:                   newline,
adamc@734:                   string "uw_sign(",
adamc@734:                   case cookieCode of
adamc@734:                       NONE => string "\"\""
adamc@734:                     | SOME code => code,
adamc@734:                   string ", r);",
adamc@734:                   newline,
adamc@734:                   string "return uw_Basis_makeSigString(ctx, r);",
adamc@734:                   newline],
adamc@734:              string "}",
adamc@734:              newline,
adamc@734:              newline,
adamc@734: 
adamc@311:              string "void uw_handle(uw_context ctx, char *request) {",
adamc@101:              newline,
adamc@863:              string "if (!strcmp(request, \"",
adamc@863:              string (OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
adamc@863:                                           file = "app.js"}),
adamc@863:              string "\")) {",
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@870: 
adamc@432:              if hasDb then
adamc@870:                  box [string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
adamc@870:                       newline,
adamc@870:                       box [p_enamed env (!expunge),
adamc@870:                            string "(ctx, cli);",
adamc@870:                            newline],
adamc@870:                       string "}",
adamc@870:                       newline,
adamc@870:                       newline,
adamc@870: 
adamc@870:                       string "void uw_initializer(uw_context ctx) {",
adamc@870:                       newline,
adamc@870:                       box [p_enamed env (!initialize),
adamc@870:                            string "(ctx, uw_unit_v);",
adamc@870:                            newline],
adamc@870:                       string "}",
adamc@870:                       newline]
adamc@432:              else
adamc@870:                  box [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@874:                                                             let
adamc@874:                                                                 val t = sql_type_in env t
adamc@874:                                                             in
adamc@874:                                                                 box [string "uw_",
adamc@874:                                                                      string (CharVector.map Char.toLower x),
adamc@874:                                                                      space,
adamc@874:                                                                      string (#p_sql_type (Settings.currentDbms ()) t),
adamc@874:                                                                      case t of
adamc@874:                                                                          Nullable _ => box []
adamc@874:                                                                        | _ => string " NOT NULL"]
adamc@874:                                                             end) 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@877:                                             box [string (#createSequence (Settings.currentDbms ()) s),
adamc@338:                                                  string ";",
adamc@338:                                                  newline,
adamc@338:                                                  newline]
adamc@754:                                           | DView (s, xts, q) =>
adamc@754:                                             box [string "CREATE VIEW",
adamc@754:                                                  space,
adamc@754:                                                  string s,
adamc@754:                                                  space,
adamc@754:                                                  string "AS",
adamc@754:                                                  space,
adamc@754:                                                  string q,
adamc@754:                                                  string ";",
adamc@754:                                                  newline,
adamc@754:                                                  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@882:         box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
adamc@274:     end
adamc@274: 
adamc@29: end