[feature] opx2js: First draft

compiler/opa2js/_tags

@@ -0,0 +1,9 @@
+# -*- conf -*- (for emacs)
+
+<**/*.{ml,mli}>: use_buildinfos, use_libbase, use_compilerlib, use_passlib
+
+<**/*.native>: thread, use_dynlink, use_graph, use_str, use_cryptokit, use_unix, use_nums, use_zip, use_buildinfos, use_libbase, use_ulex, use_libtrx, use_libqmlcompil, use_libbsl, use_opalib, use_opalang, use_opapasses, use_qmlfakecompiler, use_qmlflatcompiler, use_qml2ocaml, use_qmljsimp, use_qml2js, use_opabsl_for_compiler, use_qmlslicer, use_jslang, use_qmlcpsrewriter, use_ocamllang, use_passlib, use_compilerlib, use_pplib, use_qmlpasses, use_opacapi, use_libopa
+
+<**/opx2jsPasses.{ml,mli}>: use_jslang, use_opalib, use_opalang, use_opapasses, use_libopa, use_libqmlcompil, use_qmlpasses, use_qmlcpsrewriter, use_qmlslicer
+
+<**/pass_NodeJsPluginCompilation.{ml,mli}>: use_jslang, use_libqmlcompil, use_qmljsimp

compiler/opa2js/opx2js.ml

@@ -0,0 +1,60 @@
+(*
+    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/>.
+*)
+
+(* Opening the generic pass system. *)
+module PH = PassHandler
+
+(* FIXME: define a module InfixOperators in PassHandler *)
+(* this could by the only case an 'open' is allowed *)
+let (|+>) = PH.(|+>)
+let (|>) = PH.(|>)
+let (<?>) = PH.(<?>)
+let (&) = PH.(&)
+let (|?>) = PH.(|?>)
+let (|?|) = PH.(|?|)
+let (or) = PH.(or)
+
+(* Set title of generic pass system. *)
+let _ = PH.set_title "Opa2JS"
+
+module O2J = Opx2jsPasses
+
+(* Run all passes *)
+let code =
+  (**********************************************)
+  (* INITIALIZATION *****************************)
+  PH.init
+
+  |+> ("Welcome", O2J.pass_Welcome)
+
+  |+> ("CheckOptions", O2J.pass_CheckOptions)
+
+  |+> ("LoadEnvironment", O2J.pass_LoadEnvironment (fun e -> e
+
+    |+> ("NodeJsPluginCompilation", O2J.pass_NodeJsPluginCompilation)
+
+    |+> ("NodeJsPluginGeneration", O2J.pass_NodeJsPluginGeneration)
+
+    |> PH.return
+  ))
+
+  |> PH.return
+
+
+let () = OManager.exit code
+

compiler/opa2js/opx2jsOptions.ml

@@ -0,0 +1,69 @@
+(*
+    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/>.
+*)
+
+module Arg = Base.Arg
+module Format = BaseFormat
+module String = BaseString
+
+type t = {
+  build_dir : string;
+  extra_path : string list;
+  packages : string list;
+}
+
+let default_options = {
+  packages = [];
+  build_dir = Sys.getcwd ();
+  extra_path = [];
+}
+
+let parsed = ref false
+
+let r = ref default_options
+
+let add_packages f =
+  r := {!r with packages = f::!r.packages}
+
+let add_extra_path f =
+  r := {!r with extra_path = f::!r.extra_path}
+
+let set_build_dir build_dir = r := {!r with build_dir}
+
+let options = [
+  "--build-dir", Arg.String set_build_dir,
+  "Set the build directory";
+
+  "-I", Arg.String add_extra_path,
+  "Add the given directory to the list of directories searched";
+
+] @ OManager.Arg.options
+  @ ObjectFiles.Arg.public_options
+
+let anon_fun arg = add_packages arg
+
+let get_options () =
+  if not !parsed then (
+    Arg.parse options anon_fun "";
+    parsed := true;
+    ObjectFiles.set_relative_stdlib "stdlib.qmljs";
+    ObjectFiles.set_extrapaths ~no_stdlib:false !r.extra_path;
+  );
+  !r
+
+let print_help () =
+  Arg.usage options ""

compiler/opa2js/opx2jsPasses.ml

@@ -0,0 +1,128 @@
+(*
+    Copyright © 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/>.
+*)
+
+module List = BaseList
+
+module PH = PassHandler
+module O = Opx2jsOptions
+
+type options = Opx2jsOptions.t
+
+type ('env, 'env2) pass = (options, options, 'env, 'env2) PassHandler.pass
+
+let pass_Welcome =
+  PassHandler.make_pass
+    (fun {PH.env=()} ->
+       let options = Opx2jsOptions.get_options () in
+       OManager.verbose "Opa version %s" BuildInfos.opa_version_name ;
+       OManager.verbose "(c) 2007-%s MLstate, All Rights Reserved." BuildInfos.year;
+       OManager.verbose "Build: %s" BuildInfos.version_id;
+       PassHandler.make_env options ())
+
+let pass_CheckOptions =
+  PassHandler.make_pass
+    (fun e ->
+       if List.is_empty e.PH.options.O.packages
+       then (
+         OManager.printf "@{<bright>No packages is specify@}@.";
+         O.print_help ();
+         OManager.printf "@[<2>@{<bright>Hint@}:@\nprecise some packages@]@.";
+         exit 1;
+       ) else e
+    )
+
+type env = {
+  package : ObjectFiles.package;
+  renaming : SurfaceAstRenaming.SExpr.t;
+  gamma : QmlTypes.Env.t;
+  undot : QmlAst.expr StringMap.t IdentMap.t;
+  skipped : Ident.t IdentMap.t;
+  code : JsAst.code
+}
+
+let pass_LoadEnvironment k =
+  PassHandler.make_pass
+    (fun e ->
+       let options = e.PH.options in
+       let module RawRenaming = ObjectFiles.MakeRaw(SurfaceAstRenaming.SExpr) in
+       let module RawTyping = ObjectFiles.MakeRaw(Pass_Typing.S) in
+       let module RawTypeDefinition = ObjectFiles.MakeRaw(Pass_TypeDefinition.S) in
+       let module RawUndot = ObjectFiles.MakeRaw(Pass_Undot.S) in
+       let _ = List.fold_left
+           (fun _acc package_name ->
+              let package = package_name, FilePos.nopos "commandLine" in
+              let renaming = RawRenaming.load1 package in
+              let gamma = RawTypeDefinition.load1 package in
+              let gamma = QmlTypes.Env.Ident.from_map (RawTyping.load1 package) gamma in
+              let srenaming = QmlSimpleSlicer.get_renaming package ~side:`server in
+              let undot =
+                let {Pass_Undot. modules; aliases} = (fst (RawUndot.load1 package)) in
+                IdentMap.fold (fun a i modules -> IdentMap.add a (IdentMap.find i modules) modules)
+                  aliases modules
+              in
+              let skipped =
+                IdentMap.fold
+                  (fun cps skip acc ->
+                     IdentMap.add (IdentMap.find cps srenaming) skip acc)
+                  (QmlCpsRewriter.get_skipped package)
+                  IdentMap.empty
+              in
+              Format.eprintf "package %s@\nRenaming@[%a@]@\nGamma@[%a@]@\n%!"
+                package_name
+                (StringMap.pp ",@ "
+                   (fun fmt k (i, _) ->
+                      Format.fprintf fmt "%s => %a@\n" k OpaPrint.ident#ident i
+                   )
+                ) renaming
+                QmlTypes.Env.pp gamma
+              ;
+              k (PassHandler.make_env options
+                   {renaming; gamma; undot; skipped; package; code=[]})
+           ) 0 options.O.packages
+       in
+       PassHandler.make_env options 0
+    )
+
+
+let pass_NodeJsPluginCompilation =
+  PassHandler.make_pass
+    (fun e ->
+       let options = e.PH.options in
+       let {renaming; gamma; undot; skipped; package} = e.PH.env in
+       let env = Pass_NodeJsPluginCompilation.build_env
+         ~package ~renaming ~gamma ~undot ~skipped ~ei:()
+       in
+       let code = Pass_NodeJsPluginCompilation.process env in
+       PassHandler.make_env options {e.PH.env with code}
+    )
+
+
+let pass_NodeJsPluginGeneration =
+  PassHandler.make_pass
+    (fun e ->
+       let options = e.PH.options in
+       let {code; package} = e.PH.env in
+       let directory = Filename.concat options.O.build_dir (fst package) in
+       if not(File.check_create_path directory) then
+         OManager.error "cannot create directory '%s'" directory;
+       let jsfile = Filename.concat directory "main.js"  in
+       match File.pp_output jsfile JsPrint.debug_pp#code code with
+       | None -> PassHandler.make_env options 0
+       | Some msg -> OManager.error "%s" msg
+    )
+

compiler/opa2js/opx2jsPasses.mli

@@ -0,0 +1,15 @@
+type options = Opx2jsOptions.t
+
+type ('env, 'env2) pass = (options, options, 'env, 'env2) PassHandler.pass
+
+val pass_Welcome : (unit, options, unit, unit) PassHandler.pass
+
+val pass_CheckOptions : (unit, unit) pass
+
+type env
+
+val pass_LoadEnvironment : ((options, env) PassHandler.one_env -> int) -> (unit, int) pass
+
+val pass_NodeJsPluginCompilation : (env, env) pass
+
+val pass_NodeJsPluginGeneration : (env, int) pass