adamc@29: (* Copyright (c) 2008, Adam Chlipala
adamc@29:  * All rights reserved.
adamc@29:  *
adamc@29:  * Redistribution and use in source and binary forms, with or without
adamc@29:  * modification, are permitted provided that the following conditions are met:
adamc@29:  *
adamc@29:  * - Redistributions of source code must retain the above copyright notice,
adamc@29:  *   this list of conditions and the following disclaimer.
adamc@29:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@29:  *   this list of conditions and the following disclaimer in the documentation
adamc@29:  *   and/or other materials provided with the distribution.
adamc@29:  * - The names of contributors may not be used to endorse or promote products
adamc@29:  *   derived from this software without specific prior written permission.
adamc@29:  *
adamc@29:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@29:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@29:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@29:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@29:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@29:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@29:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@29:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@29:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@29:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@29:  * POSSIBILITY OF SUCH DAMAGE.
adamc@29:  *)
adamc@29: 
adamc@29: (* Pretty-printing C jr. *)
adamc@29: 
adamc@29: structure CjrPrint :> CJR_PRINT = struct
adamc@29: 
adamc@29: open Print.PD
adamc@29: open Print
adamc@29: 
adamc@29: open Cjr
adamc@29: 
adamc@29: structure E = CjrEnv
adamc@29: structure EM = ErrorMsg
adamc@29: 
adamc@29: val debug = ref false
adamc@29: 
adamc@29: val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
adamc@29: 
adamc@29: fun p_typ' par env (t, loc) =
adamc@29:     case t of
adamc@101:         TTop => string "void*"
adamc@109:       | TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
adamc@109:                                            space,
adamc@109:                                            string "(*)",
adamc@109:                                            space,
adamc@109:                                            string "(",
adamc@109:                                            p_typ env t1,
adamc@109:                                            string ")"])
adamc@29:       | TRecord i => box [string "struct",
adamc@29:                           space,
adamc@29:                           string "__lws_",
adamc@29:                           string (Int.toString i)]
adamc@29:       | TNamed n =>
adamc@29:         (string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n)
adamc@29:          handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
adamc@53:       | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@29: 
adamc@29: and p_typ env = p_typ' false env
adamc@29: 
adamc@29: fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@29:     handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29: 
adamc@109: fun p_enamed env n =
adamc@109:     string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@109:     handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
adamc@109: 
adamc@29: fun p_exp' par env (e, _) =
adamc@29:     case e of
adamc@29:         EPrim p => Prim.p_t p
adamc@29:       | ERel n => p_rel env n
adamc@109:       | ENamed n => p_enamed env n
adamc@109: 
adamc@53:       | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@53:       | EFfiApp (m, x, es) => box [string "lw_",
adamc@53:                                    string m,
adamc@53:                                    string "_",
adamc@53:                                    string x,
adamc@117:                                    string "(ctx, ",
adamc@53:                                    p_list (p_exp env) es,
adamc@53:                                    string ")"]
adamc@129:       | EApp (e1, e2) =>
adamc@129:         let
adamc@129:             fun unravel (f, acc) =
adamc@129:                 case #1 f of
adamc@129:                     EApp (f', arg) => unravel (f', arg :: acc)
adamc@129:                   | _ => (f, acc)
adamc@129: 
adamc@129:             val (f, args) = unravel (e1, [e2])
adamc@129:         in
adamc@129:             parenIf par (box [p_exp' true env e1,
adamc@129:                               string "(ctx,",
adamc@129:                               space,
adamc@129:                               p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129:                               string ")"])
adamc@129:         end
adamc@29: 
adamc@29:       | ERecord (i, xes) => box [string "({",
adamc@29:                                  space,
adamc@29:                                  string "struct",
adamc@29:                                  space,
adamc@29:                                  string ("__lws_" ^ Int.toString i),
adamc@29:                                  space,
adamc@29:                                  string "__lw_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@29:                                  string "__lw_tmp;",
adamc@29:                                  space,
adamc@29:                                  string "})" ]
adamc@29:       | EField (e, x) =>
adamc@29:         box [p_exp' true env e,
adamc@29:              string ".",
adamc@29:              string x]
adamc@29: 
adamc@117:       | EWrite e => box [string "(lw_write(ctx, ",
adamc@102:                          p_exp env e,
adamc@102:                          string "), lw_unit_v)"]
adamc@102: 
adamc@106:       | ESeq (e1, e2) => box [string "(",
adamc@106:                               p_exp env e1,
adamc@106:                               string ",",
adamc@106:                               space,
adamc@106:                               p_exp env e2,
adamc@106:                               string ")"]
adamc@106: 
adamc@29: and p_exp env = p_exp' false env
adamc@29: 
adamc@129: fun p_fun env (fx, n, args, ran, e) =
adamc@129:     let
adamc@129:         val nargs = length args
adamc@129:         val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129:     in
adamc@129:         box [string "static",
adamc@129:              space,
adamc@129:              p_typ env ran,
adamc@129:              space,
adamc@129:              string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129:              string "(",
adamc@129:              p_list_sep (box [string ",", space]) (fn x => x)
adamc@129:                         (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129:                                                                       box [p_typ env dom,
adamc@129:                                                                            space,
adamc@129:                                                                            p_rel env' (nargs - i - 1)]) args),
adamc@129:              string ")",
adamc@129:              space,
adamc@129:              string "{",
adamc@129:              newline,
adamc@129:              box[string "return(",
adamc@129:                  p_exp env' e,
adamc@129:                  string ");"],
adamc@129:              newline,
adamc@129:              string "}"]
adamc@129:     end
adamc@129: 
adamc@129: fun p_decl env (dAll as (d, _) : decl) =
adamc@29:     case d of
adamc@29:         DStruct (n, xts) =>
adamc@29:         box [string "struct",
adamc@29:              space,
adamc@29:              string ("__lws_" ^ Int.toString n),
adamc@29:              space,
adamc@29:              string "{",
adamc@29:              newline,
adamc@29:              p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29:                                                     space,
adamc@29:                                                     string x,
adamc@29:                                                     string ";",
adamc@29:                                                     newline]) xts,
adamc@29:              string "};"]
adamc@29: 
adamc@29:       | DVal (x, n, t, e) =>
adamc@29:         box [p_typ env t,
adamc@29:              space,
adamc@29:              string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29:              space,
adamc@29:              string "=",
adamc@29:              space,
adamc@29:              p_exp env e,
adamc@29:              string ";"]
adamc@129:       | DFun vi => p_fun env vi
adamc@129:       | DFunRec vis =>
adamc@29:         let
adamc@129:             val env = E.declBinds env dAll
adamc@29:         in
adamc@129:             box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129:                                         box [string "static",
adamc@129:                                              space,
adamc@129:                                              p_typ env ran,
adamc@129:                                              space,
adamc@129:                                              string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129:                                              string "(lw_context,",
adamc@129:                                              space,
adamc@129:                                              p_list_sep (box [string ",", space])
adamc@129:                                                         (fn (_, dom) => p_typ env dom) args,
adamc@129:                                              string ");"]) vis,
adamc@29:                  newline,
adamc@129:                  p_list_sep newline (p_fun env) vis,
adamc@129:                  newline]
adamc@29:         end
adamc@29: 
adamc@120: fun unurlify (t, loc) =
adamc@120:     case t of
adamc@120:         TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
adamc@120:       | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
adamc@120:       | TFfi ("Basis", "string") => string "lw_unurlifyString(&request)"
adamc@120: 
adamc@120:       | TRecord 0 => string "lw_unit_v"
adamc@120: 
adamc@120:       | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@120:               space)
adamc@120: 
adamc@120: fun p_page env (s, n, ts) =
adamc@120:     box [string "if (!strncmp(request, \"",
adamc@116:          string (String.toString s),
adamc@120:          string "\", ",
adamc@120:          string (Int.toString (size s)),
adamc@120:          string ")) {",
adamc@116:          newline,
adamc@120:          string "request += ",
adamc@120:          string (Int.toString (size s)),
adamc@120:          string ";",
adamc@116:          newline,
adamc@120:          string "if (*request == '/') ++request;",
adamc@119:          newline,
adamc@120:          box [string "{",
adamc@120:               newline,
adamc@120:               box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@120:                                                     space,
adamc@120:                                                     string "arg",
adamc@120:                                                     string (Int.toString i),
adamc@120:                                                     space,
adamc@120:                                                     string "=",
adamc@120:                                                     space,
adamc@120:                                                     unurlify t,
adamc@120:                                                     string ";",
adamc@120:                                                     newline]) ts),
adamc@120:               p_enamed env n,
adamc@120:               string "(",
adamc@120:               p_list_sep (box [string ",", space])
adamc@120:                          (fn x => x)
adamc@120:                          (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@120:               string ");",
adamc@120:               newline,
adamc@120:               string "return;",
adamc@120:               newline,
adamc@120:               string "}",
adamc@120:               newline,
adamc@120:               string "}"]
adamc@120:         ]
adamc@101: 
adamc@101: fun p_file env (ds, ps) =
adamc@29:     let
adamc@101:         val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31:                                              (p_decl env d,
adamc@31:                                               E.declBinds env d))
adamc@101:                              env ds
adamc@101:         val pds' = map (p_page env) ps
adamc@29:     in
adamc@101:         box [string "#include \"lacweb.h\"",
adamc@101:              newline,
adamc@101:              newline,
adamc@101:              p_list_sep newline (fn x => x) pds,
adamc@101:              newline,
adamc@117:              string "void lw_handle(lw_context ctx, char *request) {",
adamc@101:              newline,
adamc@101:              p_list_sep newline (fn x => x) pds',
adamc@101:              newline,
adamc@101:              string "}",
adamc@101:              newline]
adamc@29:     end
adamc@29: 
adamc@29: end