Skip to content
This repository
tag: v4036
Fetching contributors…

Cannot retrieve contributors at this time

file 448 lines (407 sloc) 14.753 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448
(*
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;
      "`which npm > /dev/null 2>&1 && npm root -g`";
    ])

  (* 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
    let plugins = env_bsl.BslLib.all_plugins in
    let plugins = match env_bsl.BslLib.bundled_plugin with
      | None -> plugins
      | Some p -> p :: plugins
    in
    let deps =
      List.fold_left
        (fun acc plugin ->
           let deps = JsPackage.get_dependencies plugin.BslPluginInterface.nodejs_pack in
           List.map fst deps @ acc
        ) [] plugins
    in
    let deps = List.uniq_unsorted deps in
    Format.sprintf
      "#!/usr/bin/env sh
/*usr/bin/env true
export NODE_PATH=\"%a\"
%s
*/

var dependencies = [%a];
%s
"
      (StringSet.pp ":" Format.pp_print_string) node_path

      LaunchHelper.script
      (Format.pp_list ", " (fun fmt s -> Format.fprintf fmt "'%s'" s)) deps
      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 package p
    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_:(?side:[`client | `server] -> 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
Something went wrong with that request. Please try again.