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@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@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@144: datatype 'a search =
adamc@144:          Found of 'a
adamc@144:        | NotFound
adamc@144:        | Error
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@144: 
adamc@144:         val fields = foldl (fn ((ek, _, _, ts), fields) =>
adamc@144:                                case ek of
adamc@144:                                    Core.Link => fields
adamc@144:                                  | Core.Action =>
adamc@144:                                    case List.last ts of
adamc@144:                                        (TRecord i, _) =>
adamc@144:                                        let
adamc@144:                                            val xts = E.lookupStruct env i
adamc@144:                                            val xtsSet = SS.addList (SS.empty, map #1 xts)
adamc@144:                                        in
adamc@144:                                            foldl (fn ((x, _), fields) =>
adamc@144:                                                      let
adamc@144:                                                          val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@144:                                                      in
adamc@144:                                                          SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@144:                                                                                          xtsSet'))
adamc@144:                                                      end) fields xts
adamc@144:                                        end
adamc@144:                                      | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@144:                      SM.empty ps
adamc@144: 
adamc@144:         val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144:                                   let
adamc@144:                                       val unusable = SS.foldl (fn (x', unusable) =>
adamc@144:                                                                   case SM.find (fnums, x') of
adamc@144:                                                                       NONE => unusable
adamc@144:                                                                     | SOME n => IS.add (unusable, n))
adamc@144:                                                      IS.empty xs
adamc@144: 
adamc@144:                                       fun findAvailable n =
adamc@144:                                           if IS.member (unusable, n) then
adamc@144:                                               findAvailable (n + 1)
adamc@144:                                           else
adamc@144:                                               n
adamc@144:                                   in
adamc@144:                                       SM.insert (fnums, x, findAvailable 0)
adamc@144:                                   end)
adamc@144:                     SM.empty fields
adamc@144: 
adamc@144:         fun makeSwitch (fnums, i) =
adamc@144:             case SM.foldl (fn (n, NotFound) => Found n
adamc@144:                             | (n, Error) => Error
adamc@144:                             | (n, Found n') => if n = n' then
adamc@144:                                                   Found n'
adamc@144:                                                else
adamc@144:                                                    Error) NotFound fnums of
adamc@144:                 NotFound => box [string "return",
adamc@144:                                  space,
adamc@144:                                  string "-1;"]
adamc@144:               | Found n => box [string "return",
adamc@144:                                 space,
adamc@144:                                 string (Int.toString n),
adamc@144:                                 string ";"]
adamc@144:               | Error =>
adamc@144:                 let
adamc@144:                     val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144:                                              let
adamc@144:                                                  val ch = if i < size x then
adamc@144:                                                               String.sub (x, i)
adamc@144:                                                           else
adamc@144:                                                               chr 0
adamc@144: 
adamc@144:                                                  val fnums = case CM.find (cmap, ch) of
adamc@144:                                                                  NONE => SM.empty
adamc@144:                                                                | SOME fnums => fnums
adamc@144:                                                  val fnums = SM.insert (fnums, x, n)
adamc@144:                                              in
adamc@144:                                                  CM.insert (cmap, ch, fnums)
adamc@144:                                              end)
adamc@144:                                CM.empty fnums
adamc@144: 
adamc@144:                     val cmap = CM.listItemsi cmap
adamc@144:                 in
adamc@144:                     case cmap of
adamc@144:                         [(_, fnums)] =>
adamc@144:                         box [string "if",
adamc@144:                              space,
adamc@144:                              string "(name[",
adamc@144:                              string (Int.toString i),
adamc@144:                              string "]",
adamc@144:                              space,
adamc@144:                              string "==",
adamc@144:                              space,
adamc@144:                              string "0)",
adamc@144:                              space,
adamc@144:                              string "return",
adamc@144:                              space,
adamc@144:                              string "-1;",
adamc@144:                              newline,
adamc@144:                              makeSwitch (fnums, i+1)]
adamc@144:                       | _ =>
adamc@144:                         box [string "switch",
adamc@144:                              space,
adamc@144:                              string "(name[",
adamc@144:                              string (Int.toString i),
adamc@144:                              string "])",
adamc@144:                              space,
adamc@144:                              string "{",
adamc@144:                              newline,
adamc@144:                              box (map (fn (ch, fnums) =>
adamc@144:                                           box [string "case",
adamc@144:                                                space,
adamc@144:                                                if ch = chr 0 then
adamc@144:                                                    string "0:"
adamc@144:                                                else
adamc@144:                                                    box [string "'",
adamc@144:                                                         string (Char.toString ch),
adamc@144:                                                         string "':"],
adamc@144:                                                newline,
adamc@144:                                                makeSwitch (fnums, i+1),
adamc@144:                                                newline]) cmap),
adamc@144:                              string "default:",
adamc@144:                              newline,
adamc@144:                              string "return",
adamc@144:                              space,
adamc@144:                              string "-1;",
adamc@144:                              newline,
adamc@144:                              string "}"]
adamc@144:                 end
adamc@144: 
adamc@144:         fun unurlify (t, loc) =
adamc@144:             case t of
adamc@144:                 TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
adamc@144:               | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
adamc@144:               | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
adamc@144: 
adamc@144:               | TRecord 0 => string "lw_unit_v"
adamc@144:               | TRecord i =>
adamc@144:                 let
adamc@144:                     val xts = E.lookupStruct env i
adamc@144:                 in
adamc@144:                     box [string "({",
adamc@144:                          newline,
adamc@144:                          box (map (fn (x, t) =>
adamc@144:                                       box [p_typ env t,
adamc@144:                                            space,
adamc@144:                                            string x,
adamc@144:                                            space,
adamc@144:                                            string "=",
adamc@144:                                            space,
adamc@144:                                            unurlify t,
adamc@144:                                            string ";",
adamc@144:                                            newline]) xts),
adamc@144:                          string "struct",
adamc@144:                          space,
adamc@144:                          string "__lws_",
adamc@144:                          string (Int.toString i),
adamc@144:                          space,
adamc@144:                          string "__lw_tmp",
adamc@144:                          space,
adamc@144:                          string "=",
adamc@144:                          space,
adamc@144:                          string "{",
adamc@144:                          space,
adamc@144:                          p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
adamc@144:                          space,
adamc@144:                          string "};",
adamc@144:                          newline,
adamc@144:                          string "__lw_tmp;",
adamc@144:                          newline,
adamc@144:                          string "})"]
adamc@144:                 end
adamc@144: 
adamc@144:               | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@144:                       space)
adamc@144: 
adamc@144: 
adamc@144:         fun p_page (ek, s, n, ts) =
adamc@144:             let
adamc@144:                 val (ts, defInputs, inputsVar) =
adamc@144:                     case ek of
adamc@144:                         Core.Link => (ts, string "", string "")
adamc@144:                       | Core.Action =>
adamc@144:                         case List.last ts of
adamc@144:                             (TRecord i, _) =>
adamc@144:                             let
adamc@144:                                 val xts = E.lookupStruct env i
adamc@144:                             in
adamc@144:                                 (List.drop (ts, 1),
adamc@144:                                  box [box (map (fn (x, t) => box [p_typ env t,
adamc@144:                                                                   space,
adamc@144:                                                                   string "lw_input_",
adamc@144:                                                                   string x,
adamc@144:                                                                   string ";",
adamc@144:                                                                   newline]) xts),
adamc@144:                                       newline,
adamc@144:                                       box (map (fn (x, t) =>
adamc@144:                                                    let
adamc@144:                                                        val n = case SM.find (fnums, x) of
adamc@144:                                                                    NONE => raise Fail "CjrPrint: Can't find in fnums"
adamc@144:                                                                  | SOME n => n
adamc@144:                                                    in
adamc@144:                                                        box [string "request = lw_get_input(ctx, ",
adamc@144:                                                             string (Int.toString n),
adamc@144:                                                             string ");",
adamc@144:                                                             newline,
adamc@144:                                                             string "if (request == NULL) {",
adamc@144:                                                             newline,
adamc@144:                                                             box [string "printf(\"Missing input ",
adamc@144:                                                                  string x,
adamc@144:                                                                  string "\\n\");",
adamc@144:                                                                  newline,
adamc@144:                                                                  string "exit(1);"],
adamc@144:                                                             newline,
adamc@144:                                                             string "}",
adamc@144:                                                             newline,
adamc@144:                                                             string "lw_input_",
adamc@144:                                                             string x,
adamc@144:                                                             space,
adamc@144:                                                             string "=",
adamc@144:                                                             space,
adamc@144:                                                             unurlify t,
adamc@144:                                                             string ";",
adamc@144:                                                             newline]
adamc@144:                                                    end) xts),
adamc@144:                                       string "struct __lws_",
adamc@144:                                       string (Int.toString i),
adamc@144:                                       space,
adamc@144:                                       string "lw_inputs",
adamc@144:                                       space,
adamc@144:                                       string "= {",
adamc@144:                                       newline,
adamc@144:                                       box (map (fn (x, _) => box [string "lw_input_",
adamc@144:                                                                   string x,
adamc@144:                                                                   string ",",
adamc@144:                                                                   newline]) xts),
adamc@144:                                       string "};",
adamc@144:                                       newline],
adamc@144:                                  box [string ",",
adamc@144:                                       space,
adamc@144:                                       string "lw_inputs"])
adamc@144:                             end
adamc@144: 
adamc@144:                           | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@144:             in
adamc@144:                 box [string "if (!strncmp(request, \"",
adamc@144:                      string (String.toString s),
adamc@144:                      string "\", ",
adamc@144:                      string (Int.toString (size s)),
adamc@144:                      string ")) {",
adamc@144:                      newline,
adamc@144:                      string "request += ",
adamc@144:                      string (Int.toString (size s)),
adamc@144:                      string ";",
adamc@144:                      newline,
adamc@144:                      string "if (*request == '/') ++request;",
adamc@144:                      newline,
adamc@144:                      box [string "{",
adamc@144:                           newline,
adamc@144:                           box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144:                                                                 space,
adamc@144:                                                                 string "arg",
adamc@144:                                                                 string (Int.toString i),
adamc@144:                                                                 space,
adamc@144:                                                                 string "=",
adamc@144:                                                                 space,
adamc@144:                                                                 unurlify t,
adamc@144:                                                                 string ";",
adamc@144:                                                                 newline]) ts),
adamc@144:                           defInputs,
adamc@144:                           p_enamed env n,
adamc@144:                           string "(",
adamc@144:                           p_list_sep (box [string ",", space])
adamc@144:                                      (fn x => x)
adamc@144:                                      (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144:                           inputsVar,
adamc@144:                           string ");",
adamc@144:                           newline,
adamc@144:                           string "return;",
adamc@144:                           newline,
adamc@144:                           string "}",
adamc@144:                           newline,
adamc@144:                           string "}"]
adamc@144:                     ]
adamc@144:             end
adamc@144: 
adamc@144:         val pds' = map p_page ps
adamc@29:     in
adamc@144:         box [string "#include <stdio.h>",
adamc@144:              newline,
adamc@144:              string "#include <stdlib.h>",
adamc@144:              newline,
adamc@144:              newline,
adamc@144:              string "#include \"lacweb.h\"",
adamc@101:              newline,
adamc@101:              newline,
adamc@101:              p_list_sep newline (fn x => x) pds,
adamc@101:              newline,
adamc@144:              string "int lw_inputs_len = ",
adamc@144:              string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
adamc@144:              string ";",
adamc@144:              newline,
adamc@144:              newline,
adamc@144:              string "int lw_input_num(char *name) {",
adamc@144:              newline,
adamc@144:              string "if",
adamc@144:              space,
adamc@144:              string "(name[0]",
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, 0),
adamc@144:              string "}",
adamc@144:              newline,
adamc@144:              newline,
adamc@117:              string "void lw_handle(lw_context ctx, char *request) {",
adamc@101:              newline,
adamc@101:              p_list_sep newline (fn x => x) pds',
adamc@101:              newline,
adamc@101:              string "}",
adamc@101:              newline]
adamc@29:     end
adamc@29: 
adamc@29: end