adamc@567: (* Copyright (c) 2008, Adam Chlipala
adamc@567:  * All rights reserved.
adamc@567:  *
adamc@567:  * Redistribution and use in source and binary forms, with or without
adamc@567:  * modification, are permitted provided that the following conditions are met:
adamc@567:  *
adamc@567:  * - Redistributions of source code must retain the above copyright notice,
adamc@567:  *   this list of conditions and the following disclaimer.
adamc@567:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@567:  *   this list of conditions and the following disclaimer in the documentation
adamc@567:  *   and/or other materials provided with the distribution.
adamc@567:  * - The names of contributors may not be used to endorse or promote products
adamc@567:  *   derived from this software without specific prior written permission.
adamc@567:  *
adamc@567:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@567:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@567:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@567:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@567:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@567:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@567:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@567:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@567:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@567:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@567:  * POSSIBILITY OF SUCH DAMAGE.
adamc@567:  *)
adamc@567: 
adamc@567: structure JsComp :> JSCOMP = struct
adamc@567: 
adamc@567: open Mono
adamc@567: 
adamc@567: structure EM = ErrorMsg
adamc@567: structure E = MonoEnv
adamc@567: structure U = MonoUtil
adamc@567: 
adamc@567: type state = {
adamc@567:      decls : decl list,
adamc@567:      script : string
adamc@567: }
adamc@567: 
adamc@567: fun varDepth (e, _) =
adamc@567:     case e of
adamc@567:         EPrim _ => 0
adamc@567:       | ERel _ => 0
adamc@567:       | ENamed _ => 0
adamc@567:       | ECon (_, _, NONE) => 0
adamc@567:       | ECon (_, _, SOME e) => varDepth e
adamc@567:       | ENone _ => 0
adamc@567:       | ESome (_, e) => varDepth e
adamc@567:       | EFfi _ => 0
adamc@567:       | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
adamc@567:       | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567:       | EAbs _ => 0
adamc@567:       | EUnop (_, e) => varDepth e
adamc@567:       | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567:       | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
adamc@567:       | EField (e, _) => varDepth e
adamc@567:       | ECase (e, pes, _) =>
adamc@567:         foldl Int.max (varDepth e)
adamc@567:         (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
adamc@567:       | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567:       | EError (e, _) => varDepth e
adamc@567:       | EWrite e => varDepth e
adamc@567:       | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
adamc@567:       | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
adamc@567:       | EClosure _ => 0
adamc@567:       | EQuery _ => 0
adamc@567:       | EDml _ => 0
adamc@567:       | ENextval _ => 0
adamc@567:       | EUnurlify _ => 0
adamc@567:       | EJavaScript _ => 0
adamc@568:       | ESignalReturn e => varDepth e
adamc@567: 
adamc@568: fun strcat loc es =
adamc@568:     case es of
adamc@568:         [] => (EPrim (Prim.String ""), loc)
adamc@568:       | [x] => x
adamc@568:       | x :: es' => (EStrcat (x, strcat loc es'), loc)
adamc@568: 
adamc@568: fun jsExp mode outer =
adamc@567:     let
adamc@567:         val len = length outer
adamc@567: 
adamc@567:         fun jsE inner (e as (_, loc), st) =
adamc@567:             let
adamc@567:                 fun str s = (EPrim (Prim.String s), loc)
adamc@567: 
adamc@567:                 fun var n = Int.toString (len + inner - n - 1)
adamc@567: 
adamc@567:                 fun patCon pc =
adamc@567:                     case pc of
adamc@567:                         PConVar n => str (Int.toString n)
adamc@567:                       | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
adamc@567: 
adamc@568: 
adamc@567: 
adamc@567:                 fun isNullable (t, _) =
adamc@567:                     case t of
adamc@567:                         TOption _ => true
adamc@567:                       | _ => false
adamc@567: 
adamc@567:                 fun unsupported s =
adamc@567:                   (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
adamc@567:                    (str "ERROR", st))
adamc@568: 
adamc@568:                 val strcat = strcat loc
adamc@567:             in
adamc@567:                 case #1 e of
adamc@567:                     EPrim (Prim.String s) =>
adamc@567:                     (str ("\""
adamc@567:                           ^ String.translate (fn #"'" =>
adamc@568:                                                  if mode = Attribute then
adamc@567:                                                      "\\047"
adamc@567:                                                  else
adamc@567:                                                      "'"
adamc@567:                                                | #"<" =>
adamc@568:                                                  if mode = Script then
adamc@567:                                                      "<"
adamc@567:                                                  else
adamc@567:                                                      "\\074"
adamc@567:                                                | #"\\" => "\\\\"
adamc@567:                                                | ch => String.str ch) s
adamc@567:                           ^ "\""), st)
adamc@567:                   | EPrim p => (str (Prim.toString p), st)
adamc@567:                   | ERel n =>
adamc@567:                     if n < inner then
adamc@567:                         (str ("uwr" ^ var n), st)
adamc@567:                     else
adamc@567:                         (str ("uwo" ^ var n), st)
adamc@567:                   | ENamed _ => raise Fail "Named"
adamc@567:                   | ECon (_, pc, NONE) => (patCon pc, st)
adamc@567:                   | ECon (_, pc, SOME e) =>
adamc@567:                     let
adamc@567:                         val (s, st) = jsE inner (e, st)
adamc@567:                     in
adamc@567:                         (strcat [str "{n:",
adamc@567:                                  patCon pc,
adamc@567:                                  str ",v:",
adamc@567:                                  s,
adamc@567:                                  str "}"], st)
adamc@567:                     end
adamc@567:                   | ENone _ => (str "null", st)
adamc@567:                   | ESome (t, e) =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567:                     in
adamc@567:                         (if isNullable t then
adamc@567:                              strcat [str "{v:", e, str "}"]
adamc@567:                          else
adamc@567:                              e, st)
adamc@567:                     end
adamc@567: 
adamc@567:                   | EFfi (_, s) => (str s, st)
adamc@567:                   | EFfiApp (_, s, []) => (str (s ^ "()"), st)
adamc@567:                   | EFfiApp (_, s, [e]) =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567:                         
adamc@567:                     in
adamc@567:                         (strcat [str (s ^ "("),
adamc@567:                                  e,
adamc@567:                                  str ")"], st)
adamc@567:                     end
adamc@567:                   | EFfiApp (_, s, e :: es) =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567:                         val (es, st) = ListUtil.foldlMapConcat
adamc@567:                                            (fn (e, st) =>
adamc@567:                                                let
adamc@567:                                                    val (e, st) = jsE inner (e, st)
adamc@567:                                                in
adamc@567:                                                    ([str ",", e], st)
adamc@567:                                                end)
adamc@567:                                            st es
adamc@567:                     in
adamc@567:                         (strcat (str (s ^ "(")
adamc@567:                                  :: e
adamc@567:                                  :: es
adamc@567:                                  @ [str ")"]), st)
adamc@567:                     end
adamc@567: 
adamc@567:                   | EApp (e1, e2) =>
adamc@567:                     let
adamc@567:                         val (e1, st) = jsE inner (e1, st)
adamc@567:                         val (e2, st) = jsE inner (e2, st)
adamc@567:                     in
adamc@567:                         (strcat [e1, str "(", e2, str ")"], st)
adamc@567:                     end
adamc@567:                   | EAbs (_, _, _, e) =>
adamc@567:                     let
adamc@567:                         val locals = List.tabulate
adamc@567:                                      (varDepth e,
adamc@567:                                    fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";"))
adamc@567:                         val (e, st) = jsE (inner + 1) (e, st)
adamc@567:                     in
adamc@567:                         (strcat (str ("function(uwr"
adamc@567:                                       ^ Int.toString (len + inner)
adamc@567:                                       ^ "){")
adamc@567:                                  :: locals
adamc@567:                                  @ [str "return ",
adamc@567:                                     e,
adamc@567:                                     str "}"]),
adamc@567:                          st)
adamc@567:                     end
adamc@567: 
adamc@567:                   | EUnop (s, e) =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567:                     in
adamc@567:                         (strcat [str ("(" ^ s),
adamc@567:                                  e,
adamc@567:                                  str ")"],
adamc@567:                          st)
adamc@567:                     end
adamc@567:                   | EBinop (s, e1, e2) =>
adamc@567:                     let
adamc@567:                         val (e1, st) = jsE inner (e1, st)
adamc@567:                         val (e2, st) = jsE inner (e2, st)
adamc@567:                     in
adamc@567:                         (strcat [str "(",
adamc@567:                                  e1,
adamc@567:                                  str s,
adamc@567:                                  e2,
adamc@567:                                  str ")"],
adamc@567:                          st)
adamc@567:                     end
adamc@567: 
adamc@567:                   | ERecord [] => (str "null", st)
adamc@567:                   | ERecord [(x, e, _)] =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567:                     in
adamc@567:                         (strcat [str "{uw_x:", e, str "}"], st)
adamc@567:                     end
adamc@567:                   | ERecord ((x, e, _) :: xes) =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567: 
adamc@567:                         val (es, st) =
adamc@567:                             foldr (fn ((x, e, _), (es, st)) =>
adamc@567:                                       let
adamc@567:                                           val (e, st) = jsE inner (e, st)
adamc@567:                                       in
adamc@567:                                           (str (",uw_" ^ x ^ ":")
adamc@567:                                            :: e
adamc@567:                                            :: es,
adamc@567:                                            st)
adamc@567:                                       end)
adamc@567:                                   ([str "}"], st) xes
adamc@567:                     in
adamc@567:                         (strcat (str ("{uw_" ^ x ^ ":")
adamc@567:                                  :: e
adamc@567:                                  :: es),
adamc@567:                          st)
adamc@567:                     end
adamc@567:                   | EField (e, x) =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567:                     in
adamc@567:                         (strcat [e,
adamc@567:                                  str ("." ^ x)], st)
adamc@567:                     end
adamc@567: 
adamc@567:                   | ECase _ => raise Fail "Jscomp: ECase"
adamc@567: 
adamc@567:                   | EStrcat (e1, e2) =>
adamc@567:                     let
adamc@567:                         val (e1, st) = jsE inner (e1, st)
adamc@567:                         val (e2, st) = jsE inner (e2, st)
adamc@567:                     in
adamc@567:                         (strcat [str "(", e1, str "+", e2, str ")"], st)
adamc@567:                     end
adamc@567: 
adamc@567:                   | EError (e, _) =>
adamc@567:                     let
adamc@567:                         val (e, st) = jsE inner (e, st)
adamc@567:                     in
adamc@567:                         (strcat [str "alert(\"ERROR: \"+", e, str ")"],
adamc@567:                          st)
adamc@567:                     end
adamc@567: 
adamc@568:                   | EWrite e =>
adamc@568:                     let
adamc@568:                         val (e, st) = jsE inner (e, st)
adamc@568:                     in
adamc@568:                         (strcat [str "document.write(",
adamc@568:                                  e,
adamc@569:                                  str ".v)"], st)
adamc@568:                     end
adamc@567: 
adamc@567:                   | ESeq (e1, e2) =>
adamc@567:                     let
adamc@567:                         val (e1, st) = jsE inner (e1, st)
adamc@567:                         val (e2, st) = jsE inner (e2, st)
adamc@567:                     in
adamc@567:                         (strcat [str "(", e1, str ",", e2, str ")"], st)
adamc@567:                     end
adamc@567:                   | ELet (_, _, e1, e2) =>
adamc@567:                     let
adamc@567:                         val (e1, st) = jsE inner (e1, st)
adamc@567:                         val (e2, st) = jsE (inner + 1) (e2, st)
adamc@567:                     in
adamc@567:                         (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="),
adamc@567:                                  e1,
adamc@567:                                  str ",",
adamc@567:                                  e2,
adamc@567:                                  str ")"], st)
adamc@567:                     end
adamc@567: 
adamc@567:                   | EClosure _ => unsupported "EClosure"
adamc@567:                   | EQuery _ => unsupported "Query"
adamc@567:                   | EDml _ => unsupported "DML"
adamc@567:                   | ENextval _ => unsupported "Nextval"
adamc@567:                   | EUnurlify _ => unsupported "EUnurlify"
adamc@567:                   | EJavaScript _ => unsupported "Nested JavaScript"
adamc@568:                   | ESignalReturn e =>
adamc@568:                     let
adamc@568:                         val (e, st) = jsE inner (e, st)
adamc@568:                     in
adamc@569:                         (strcat [str "sreturn(",
adamc@569:                                  e,
adamc@569:                                  str ")"],
adamc@568:                          st)
adamc@568:                     end
adamc@567:             end
adamc@567:     in
adamc@567:         jsE
adamc@567:     end
adamc@567: 
adamc@567: val decl : state -> decl -> decl * state =
adamc@567:     U.Decl.foldMapB {typ = fn x => x,
adamc@567:                      exp = fn (env, e, st) =>
adamc@568:                               let
adamc@568:                                   fun doCode m env e =
adamc@568:                                       let
adamc@568:                                           val len = length env
adamc@568:                                           fun str s = (EPrim (Prim.String s), #2 e)
adamc@568: 
adamc@568:                                           val locals = List.tabulate
adamc@568:                                                            (varDepth e,
adamc@568:                                                          fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
adamc@568:                                           val (e, st) = jsExp m env 0 (e, st)
adamc@568:                                       in
adamc@568:                                           (#1 (strcat (#2 e) (locals @ [e])), st)
adamc@568:                                       end
adamc@568:                               in
adamc@568:                                   case e of
adamc@568:                                       EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e
adamc@568:                                     | EJavaScript (m, e) => doCode m env e
adamc@568:                                     | _ => (e, st)
adamc@568:                               end,
adamc@567:                      decl = fn (_, e, st) => (e, st),
adamc@567:                      bind = fn (env, U.Decl.RelE (_, t)) => t :: env
adamc@567:                              | (env, _) => env}
adamc@567:                     []
adamc@567: 
adamc@567: fun process file =
adamc@567:     let
adamc@567:         fun doDecl (d, st) =
adamc@567:             let
adamc@567:                 val (d, st) = decl st d
adamc@567:             in
adamc@567:                 (List.revAppend (#decls st, [d]),
adamc@567:                  {decls = [],
adamc@567:                   script = #script st})
adamc@567:             end
adamc@567: 
adamc@567:         val (ds, st) = ListUtil.foldlMapConcat doDecl
adamc@567:                        {decls = [],
adamc@567:                         script = ""}
adamc@567:                        file
adamc@569: 
adamc@569:         val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
adamc@569:         fun lines acc =
adamc@569:             case TextIO.inputLine inf of
adamc@569:                 NONE => String.concat (rev acc)
adamc@569:               | SOME line => lines (line :: acc)
adamc@569:         val lines = lines []
adamc@567:     in
adamc@569:         TextIO.closeIn inf;
adamc@569:         (DJavaScript lines, ErrorMsg.dummySpan) :: ds
adamc@567:     end
adamc@567: 
adamc@567: end