qml2js.ml

(*
    Copyright © 2011, 2012 MLstate

    This file is part of Opa.

    Opa is free software: you can redistribute it and/or modify it under the
    terms of the GNU Affero General Public License, version 3, as published by
    the Free Software Foundation.

    Opa is distributed in the hope that it will be useful, but WITHOUT ANY
    WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
    FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
    more details.

    You should have received a copy of the GNU Affero General Public License
    along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)

(**
   @author Mathieu Barbin
   @author Maxime Audouin
   @author Quentin Bourgerie
*)

(* depends *)
module List = Base.List
module Format = BaseFormat

(* alias *)
module J = Qml2jsOptions
module BPI = BslPluginInterface
module JA = JsAst

(** some type are shared with qml2ocaml, some not *)

type env_js_output =
    {
      (** path/name without build directory * contents *)
      generated_files : (string * string) list ;
    }

let wclass =
  let doc = "Javascript compiler warnings" in
  WarningClass.create ~name:"jscompiler" ~doc ~err:false ~enable:true ()

type nodejs_module = string

type linked_file =
| ExtraLib of nodejs_module
| Plugin of nodejs_module

type loaded_file = linked_file * string

let nodejs_module_of_linked_file = function
  | ExtraLib m -> m
  | Plugin m -> Filename.basename m

let system_path =
  try Sys.getenv InstallDir.name
  with Not_found -> "."

let static_path =
  Filename.concat system_path InstallDir.lib_opa

let plugin_object name =
  (* pluginNodeJsPackage.js *)
  name ^ BslConvention.Suffix.nodejspackage ^ ".js"

let plugin_main_file plugin =
  (* Some plugin_path/plugin.opp/pluginNodeJsPackage.js or None*)
  match plugin.BPI.basename, plugin.BPI.path with
  | Some name, Some path ->
    Some (Filename.concat path (plugin_object name))
  | _, _ -> None

(**
   PASSES :
   -------
  // Command line passes
   returns a : env_bsl, env_blender

   val js_generation : argv_options -> env_js_input -> env_js_output
   val js_treat : argv_options -> env_js_output -> int

   NEEDED from any instance of a js-compiler :
   val qml_to_js : qml_to_js
*)

type loaded_bsl = {
  regular : loaded_file list;
  bundled : JsPackage.t option;
  generated_ast: JA.code
}

module JsTreat :
sig
  val js_bslfilesloading : Qml2jsOptions.t -> BslLib.env_bsl ->
    loaded_bsl
  val js_generation : ?depends:string list -> Qml2jsOptions.t -> BslLib.env_bsl ->
    loaded_bsl -> J.env_js_input -> env_js_output
  val js_treat : Qml2jsOptions.t -> env_js_output -> int
end =
struct
  open Qml2jsOptions

  let default_node_path = lazy (
    let static_path =
      Filename.concat (
        try Sys.getenv InstallDir.name
        with Not_found -> ".")
        InstallDir.lib_opa
    in
    StringSet.from_list [
      "$NODE_PATH";
      "node_modules";
      static_path;
      "/usr/local/lib/node_modules";
    ])

  (* Write shell script incantation to check dependencies,
     set load path, etc *)
  let launcher_header env_bsl =
    let node_path =
      ObjectFiles.fold_dir ~packages:true ~deep:true
        (fun node_path filename ->
           StringSet.add (Filename.dirname filename) node_path)
        (Lazy.force default_node_path)
    in
    let node_path =
      List.fold_left
        (fun node_path {BPI. has_server_code; path; _} ->
           if not has_server_code then node_path
           else match path with
           | None -> node_path
           | Some path -> StringSet.add (Filename.dirname path) node_path
        ) node_path env_bsl.BslLib.all_plugins
    in
    Format.sprintf
      "#!/usr/bin/env sh
/*usr/bin/env true
export NODE_PATH=\"%a\"
%s
*/

var dependencies = ['mongodb', 'formidable', 'nodemailer', 'simplesmtp', 'imap'];
var opa_dependencies = ['opa-js-runtime-cps'];
%s
"
      (StringSet.pp ":" Format.pp_print_string) node_path
      LaunchHelper.script
      LaunchHelper.js

  let extrafiles () =
    match ObjectFiles.get_current_package_name () with
    | "" -> []
    | package -> [
        "README.md",
        (Format.sprintf "\
# %s.opx
This is a module generated by Opa compiler (%s)

" package BuildInfos.opa_version_name)
      ]

  (* JS statement to require library [lib] *)
  let require_stm name lib =
    let call = JsCons.Expr.call ~pure:false
      (JsCons.Expr.native "require")
      [(JsCons.Expr.string lib)] in
    match name with
    | Some name ->
        JsCons.Statement.var
          (JsCons.Ident.native name)
          ~expr:call
    | None ->
        JsCons.Statement.expr call

  let js_bslfilesloading env_opt env_bsl =
    (* 1) extra libraries *)
    let extra_lib = List.filter_map (function
      | `server (lib, conf) -> Some (lib, conf)
      | _ -> None
    ) env_opt.extra_lib
    in
    let loaded_files =
      let fold acc (extra_lib, conf) =
        let () =
          (*
            TODO: refactor so that conf is not ignored,
            and optimization pass applied
          *)
          ignore conf
        in
        let get t =
          let contents = File.content (Filename.concat t "main.js") in
          (ExtraLib (Filename.basename t), contents)::acc
        in
        match File.get_locations ~dir:true env_opt.extra_path extra_lib with
        | [] ->
            OManager.error (
              "Cannot find extra-lib @{<bright>%s@} in search path@\n"^^
              "@[<2>@{<bright>Hint@}:@\nPerhaps a missing @{<bright>-I@} ?@]" ) extra_lib
        | [t] -> get t
        | (t::_) as all ->
            OManager.warning ~wclass:WarningClass.bsl_loading (
              "extra-lib @{<bright>%s@} is found in several places@\n%s\n"^^
              "I will use this one : @{<bright>%s@}" ) extra_lib (String.concat " " all) t ;
            get t
      in
      List.fold_left fold [] extra_lib
    in

    (* 2) loaded bsl containing js files order : since the generated
       code contains call to bypass of bsl, it is too dangerous to put
       the extra-libs between bsl and the generated code *)
    let loaded_files =
      let plugins = env_bsl.BslLib.all_external_plugins in
      let fold acc loader =
        if not (JsPackage.is_empty loader.BslPluginInterface.nodejs_pack) then
          match plugin_main_file loader with
          | Some filename ->
              let content = File.content filename in
              (Plugin filename, content) :: acc
          | None -> acc
        else
          acc
      in
      List.fold_left fold loaded_files plugins
    in
    let ast = List.flatten (List.rev_map (fun (file, content) ->
      (*
        TODO: we must take care about conf,
        and not parse file tagged as Verbatim
      *)
      try
        JsParse.String.code ~throw_exn:true content
      with JsParse.Exception error -> (
        let _ = File.output "jserror.js" content in
        OManager.error "JavaScript parser error on file '%s'\n%a\n"
          (nodejs_module_of_linked_file file) JsParse.pp error;
      )
    ) loaded_files)
    in

    (* Correct reverse order produced by fold *)
    let loaded_files = List.rev loaded_files in
    let bundled, ast = match env_bsl.BslLib.bundled_plugin with
      | Some plugin ->
          let pack = plugin.BPI.nodejs_pack in
          let code = JsPackage.get_code pack in
          Some pack, code @ ast
      | None -> None, ast in
    { regular = loaded_files; bundled; generated_ast = ast; }

  let get_js_init env_js_input = List.flatten (
    List.map
      (fun (_, x) -> match x with
       | `ast ast -> ast
       | `string str ->
           OManager.i_error "JS INIT CONTAINS UNEXPECTED PROJECTION : %s\n" str
      )
      env_js_input.Qml2jsOptions.js_init_contents)

  let compilation_generation ?(depends=[]) ?package env_opt
      bundled_plugin env_js_input =
    let js_init = get_js_init env_js_input in
    let js_code = List.map snd js_init @ env_js_input.js_code in
    let package =
      match package with
      | None ->
          let package =
            JsPackage.default
              ~name:(Printf.sprintf "%s.opx" (ObjectFiles.get_current_package_name ())) in
          JsPackage.set_build_dir package env_opt.compilation_directory
      | Some package -> package
    in
    let package = match bundled_plugin with
      | None -> package
      | Some p -> JsPackage.merge p package
    in
    let package = List.fold_left JsPackage.add_file package (extrafiles ()) in
    let package =
      let depends = List.map (fun d -> d, BuildInfos.opa_version_name) depends in
      JsPackage.add_dependencies package depends
    in
    let package = JsPackage.add_code package js_code in
    JsPackage.write package

  let linking_generation ?depends env_opt env_bsl loaded_bsl env_js_input =
    let package = JsPackage.default ~name:"link" in
    let package = JsPackage.set_build_dir package (Filename.dirname env_opt.target) in
    let package = JsPackage.set_main package (Filename.basename env_opt.target) in
    let package = JsPackage.add_verbatim package (launcher_header env_bsl) in
    let package = JsPackage.set_perm package 0o755 in
    compilation_generation ?depends ~package env_opt loaded_bsl.bundled env_js_input

  let bundle_generation env_opt env_bsl =
    match Qml2jsBackendOptions.bundle () with
    | None -> ()
    | Some bundle ->
        OManager.verbose "Create bundle %s" bundle;
        let dir =
          Filename.concat env_opt.compilation_directory
            (Printf.sprintf "%s.bundle"
               (Filename.basename
                  (Filename.chop_extension env_opt.target)))
        in
        File.remove_rec dir;
        let concat = Filename.concat (Filename.concat dir "node_modules") in
        let copy src dst =
          match File.copy src dst with
          | 0 -> ()
          | _ ->
              OManager.i_error "Could not copy @{<bright>%s@} to @{<bright>%s@}"
                src dst
        in
        (* JavaScript file *)
        copy env_opt.target (Filename.concat dir (Filename.basename env_opt.target));
        (* Opa packages *)
        ObjectFiles.iter_dir ~packages:true ~deep:true
          (fun filename ->
             let copy file =
               let src = Filename.concat filename file in
               let dst = concat (Filename.concat (Filename.basename filename) file) in
               copy src dst
               in
             (* FIXME: Remove "static filenames" *)
             copy "main.js";
             copy "package.json"
          );
        (* Opa plugins *)
        List.iter
          (fun {BPI. has_server_code; path; basename; _} ->
             if not has_server_code  then ()
             else match path, basename with
             | Some path, Some name ->
                 let copy file =
                   copy
                     (Filename.concat path file)
                     (concat (Filename.concat (Filename.basename path) file))
                 in
                 (* FIXME: Remove "static filenames" *)
                 copy (plugin_object name);
                 copy "package.json"
             | _ -> ())
          env_bsl.BslLib.all_plugins;
        (* Opa static lib *)
        let () =
          let runtime_path = Filename.concat static_path "opa-js-runtime-cps" in
          let bundle_path = concat "opa-js-runtime-cps" in
          let copy file =
            let src = Filename.concat runtime_path file in
            let dst = Filename.concat bundle_path file in
            copy src dst
          in
          copy "main.js";
          copy "package.json"
        in
        (* Make the tarball *)
        let cwd = Unix.getcwd () in
        Unix.chdir dir;
        let code =
          let bundle =
            if Filename.is_relative bundle then Filename.concat cwd bundle
            else bundle
          in
          Sys.command (Printf.sprintf "tar czf \"%s\" *" bundle)
        in
        Unix.chdir cwd;
        File.remove_rec dir;
        match code with
        | 0 -> ()
        | _ -> OManager.error "Could not create bundle @{<bright>%s@}" bundle


  let js_generation ?depends env_opt env_bsl loaded_bsl env_js_input =
    begin match ObjectFiles.compilation_mode () with
    | `compilation ->
        compilation_generation ?depends env_opt loaded_bsl.bundled env_js_input
    | `init -> ()
    | `linking ->
        linking_generation ?depends env_opt env_bsl loaded_bsl env_js_input;
        bundle_generation env_opt env_bsl
    | `prelude -> assert false
    end;
    { generated_files = [env_opt.target, ""] }

  let js_treat env_opt env_js_output =
    if not env_opt.exe_run
    then 0
    else
      let args = env_opt.exe_argv in
      let args = args @ ( List.map fst env_js_output.generated_files ) in
      let prog = fst (List.hd env_js_output.generated_files) in
      let prog = Filename.concat (Sys.getcwd ()) prog in
      OManager.verbose "building finished, will run @{<bright>%s@}" prog ;
      let command = String.concat " " (prog::args) in
      OManager.verbose "exec$ %s" command ;
      let args = Array.of_list (prog::args) in
      let run () = Unix.execvp prog args in
      Unix.handle_unix_error run ()
end

module Sugar :
sig
  val for_opa : val_:(string -> QmlAst.ident) ->
                ?bsl:JsAst.code ->
                closure_map:Ident.t IdentMap.t ->
                is_distant:(Ident.t -> bool) ->
                renaming:QmlRenamingMap.t ->
                bsl_lang:BslLanguage.t ->
                exported:IdentSet.t ->
                (module Qml2jsOptions.JsBackend) ->
                Qml2jsOptions.t ->
                BslLib.env_bsl ->
                QmlTyper.env ->
                QmlAst.code ->
                J.env_js_input
  val dummy_for_opa : (module Qml2jsOptions.JsBackend) -> unit
end
=
struct
  let for_opa ~val_ ?bsl:bsl_code ~closure_map ~is_distant ~renaming ~bsl_lang ~exported
      back_end argv env_bsl env_typer code =
    let module M = (val back_end : Qml2jsOptions.JsBackend) in
    let env_js_input =
      M.compile ~val_ ?bsl:bsl_code ~closure_map ~is_distant ~renaming ~bsl_lang ~exported
        argv env_bsl env_typer code
    in
    env_js_input
  let dummy_for_opa backend =
    let module M = (val backend : Qml2jsOptions.JsBackend) in
    M.dummy_compile ()
end