melange: replace module_system and javascript_extension (#7193)

* melange: replace `module_system` and `javascript_extension`

Signed-off-by: Antonio Nuno Monteiro <[email protected]>

otherlibs/stdune/src/filename.ml

@@ -2,6 +2,10 @@ include Stdlib.Filename
 
 type t = string
 
+module Extension = struct
+  type nonrec t = t
+end
+
 let split_extension fn =
   let ext = extension fn in
   (String.sub fn ~pos:0 ~len:(String.length fn - String.length ext), ext)

otherlibs/stdune/src/filename.mli

@@ -9,7 +9,11 @@ end
 (* TODO add invariants and make this abstract or private *)
 type t = string
 
-val split_extension : t -> string * string
+module Extension : sig
+  type nonrec t = t
+end
+
+val split_extension : t -> string * Extension.t
 
 val split_extension_after_dot : t -> string * string
 

src/dune_rules/melange/melange.ml

@@ -5,6 +5,8 @@ module Module_system = struct
     | Es6
     | CommonJs
 
+  let default = (CommonJs, ".js")
+
   let to_string = function
     | Es6 -> "es6"
     | CommonJs -> "commonjs"

src/dune_rules/melange/melange.mli

@@ -5,6 +5,8 @@ module Module_system : sig
     | Es6
     | CommonJs
 
+  val default : t * Filename.Extension.t
+
   val to_string : t -> string
 end
 

src/dune_rules/melange/melange_rules.ml

@@ -106,60 +106,66 @@ let compile_info ~scope (mel : Melange_stanzas.Emit.t) =
     ~allow_overlaps:mel.allow_overlapping_dependencies ~forbidden_libraries:[]
     mel.libraries ~pps ~dune_version ~merlin_ident
 
-let js_targets_of_modules modules ~js_ext ~output =
-  Modules.fold_no_vlib modules ~init:Path.Set.empty ~f:(fun m acc ->
-      if Module.has m ~ml_kind:Impl then
-        let target = Path.build @@ make_js_name ~js_ext ~output m in
-        Path.Set.add acc target
-      else acc)
+let js_targets_of_modules modules ~module_systems ~output =
+  List.map module_systems ~f:(fun (_, js_ext) ->
+      Modules.fold_no_vlib modules ~init:Path.Set.empty ~f:(fun m acc ->
+          if Module.has m ~ml_kind:Impl then
+            let target = Path.build @@ make_js_name ~js_ext ~output m in
+            Path.Set.add acc target
+          else acc))
+  |> Path.Set.union_all
 
-let js_targets_of_libs sctx libs ~js_ext ~target_dir =
-  let of_lib lib =
-    let open Memo.O in
-    let+ modules = impl_only_modules_defined_in_this_lib sctx lib in
-    let output = output_of_lib ~target_dir lib in
-    List.rev_map modules ~f:(fun m ->
-        Path.build @@ make_js_name ~output ~js_ext m)
-  in
-  Resolve.Memo.List.concat_map libs ~f:(fun lib ->
-      let open Memo.O in
-      let* base = of_lib lib in
-      match Lib.implements lib with
-      | None -> Resolve.Memo.return base
-      | Some vlib ->
-        let open Resolve.Memo.O in
-        let* vlib = vlib in
-        let+ for_vlib = Resolve.Memo.lift_memo (of_lib vlib) in
-        List.rev_append for_vlib base)
+let js_targets_of_libs sctx libs ~module_systems ~target_dir =
+  Resolve.Memo.List.concat_map module_systems ~f:(fun (_, js_ext) ->
+      let of_lib lib =
+        let open Memo.O in
+        let+ modules = impl_only_modules_defined_in_this_lib sctx lib in
+        let output = output_of_lib ~target_dir lib in
+        List.rev_map modules ~f:(fun m ->
+            Path.build @@ make_js_name ~output ~js_ext m)
+      in
+      Resolve.Memo.List.concat_map libs ~f:(fun lib ->
+          let open Memo.O in
+          let* base = of_lib lib in
+          match Lib.implements lib with
+          | None -> Resolve.Memo.return base
+          | Some vlib ->
+            let open Resolve.Memo.O in
+            let* vlib = vlib in
+            let+ for_vlib = Resolve.Memo.lift_memo (of_lib vlib) in
+            List.rev_append for_vlib base))
 
-let build_js ~loc ~dir ~pkg_name ~mode ~module_system ~output ~obj_dir ~sctx
-    ~includes ~js_ext m =
+let build_js ~loc ~dir ~pkg_name ~mode ~module_systems ~output ~obj_dir ~sctx
+    ~includes m =
   let open Memo.O in
   let* compiler = Melange_binary.melc sctx ~loc:(Some loc) ~dir in
-  let src = Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Melange Cmj) in
-  let output = make_js_name ~output ~js_ext m in
-  let obj_dir = [ Command.Args.A "-I"; Path (Obj_dir.melange_dir obj_dir) ] in
-  let melange_package_args =
-    let pkg_name_args =
-      match pkg_name with
-      | None -> []
-      | Some pkg_name ->
-        [ "--bs-package-name"; Package.Name.to_string pkg_name ]
-    in
-    let js_modules_str = Melange.Module_system.to_string module_system in
-    "--bs-module-type" :: js_modules_str :: pkg_name_args
-  in
-  Super_context.add_rule sctx ~dir ~loc ~mode
-    (Command.run
-       ~dir:(Path.build (Super_context.context sctx).build_dir)
-       compiler
-       [ Command.Args.S obj_dir
-       ; Command.Args.as_any includes
-       ; As melange_package_args
-       ; A "-o"
-       ; Target output
-       ; Dep src
-       ])
+  Memo.parallel_iter module_systems ~f:(fun (module_system, js_ext) ->
+      let src = Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Melange Cmj) in
+      let output = make_js_name ~output ~js_ext m in
+      let obj_dir =
+        [ Command.Args.A "-I"; Path (Obj_dir.melange_dir obj_dir) ]
+      in
+      let melange_package_args =
+        let pkg_name_args =
+          match pkg_name with
+          | None -> []
+          | Some pkg_name ->
+            [ "--bs-package-name"; Package.Name.to_string pkg_name ]
+        in
+        let js_modules_str = Melange.Module_system.to_string module_system in
+        "--bs-module-type" :: js_modules_str :: pkg_name_args
+      in
+      Super_context.add_rule sctx ~dir ~loc ~mode
+        (Command.run
+           ~dir:(Path.build (Super_context.context sctx).build_dir)
+           compiler
+           [ Command.Args.S obj_dir
+           ; Command.Args.as_any includes
+           ; As melange_package_args
+           ; A "-o"
+           ; Target output
+           ; Dep src
+           ]))
 
 let setup_emit_cmj_rules ~sctx ~dir ~scope ~expander ~dir_contents
     (mel : Melange_stanzas.Emit.t) =
@@ -213,10 +219,10 @@ let setup_emit_cmj_rules ~sctx ~dir ~scope ~expander ~dir_contents
       match mel.alias with
       | None -> Memo.return ()
       | Some alias_name ->
-        let js_ext = mel.javascript_extension in
+        let module_systems = mel.module_systems in
         let deps =
           js_targets_of_modules ~output:(`Private_library_or_emit target_dir)
-            ~js_ext modules
+            ~module_systems modules
           |> Action_builder.path_set
         in
         let alias = Alias.make alias_name ~dir in
@@ -227,7 +233,7 @@ let setup_emit_cmj_rules ~sctx ~dir ~scope ~expander ~dir_contents
           @@
           let open Resolve.Memo.O in
           Compilation_context.requires_link cctx
-          >>= js_targets_of_libs sctx ~js_ext ~target_dir
+          >>= js_targets_of_libs sctx ~module_systems ~target_dir
         in
         Action_builder.paths deps)
         |> Rules.Produce.Alias.add_deps alias
@@ -266,7 +272,7 @@ let setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir
   let requires_link = Lib.Compile.requires_link compile_info in
   let pkg_name = Option.map mel.package ~f:Package.name in
   let loc = mel.loc in
-  let js_ext = mel.javascript_extension in
+  let module_systems = mel.module_systems in
   let* requires_link = Memo.Lazy.force requires_link in
   let includes = cmj_includes ~requires_link ~scope in
   let modules_for_js =
@@ -276,12 +282,12 @@ let setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir
   let output = `Private_library_or_emit target_dir in
   let obj_dir = Obj_dir.of_local obj_dir in
   Memo.parallel_iter modules_for_js ~f:(fun m ->
-      build_js ~dir ~loc ~pkg_name ~mode ~module_system:mel.module_system
-        ~output ~obj_dir ~sctx ~includes ~js_ext m)
+      build_js ~dir ~loc ~pkg_name ~mode ~module_systems ~output ~obj_dir ~sctx
+        ~includes m)
 
 let setup_js_rules_libraries ~dir ~scope ~target_dir ~sctx ~requires_link ~mode
     (mel : Melange_stanzas.Emit.t) =
-  let build_js = build_js ~sctx ~mode ~js_ext:mel.javascript_extension in
+  let build_js = build_js ~sctx ~mode ~module_systems:mel.module_systems in
   Memo.parallel_iter requires_link ~f:(fun lib ->
       let open Memo.O in
       let lib_name = Lib.name lib in
@@ -294,7 +300,7 @@ let setup_js_rules_libraries ~dir ~scope ~target_dir ~sctx ~requires_link ~mode
       let build_js =
         let obj_dir = Lib_info.obj_dir info in
         let pkg_name = Lib_info.package info in
-        build_js ~loc ~pkg_name ~module_system:mel.module_system ~obj_dir
+        build_js ~loc ~pkg_name ~obj_dir
       in
       let* includes =
         let+ requires_link =

src/dune_rules/melange/melange_stanzas.ml

@@ -6,7 +6,7 @@ module Emit = struct
     { loc : Loc.t
     ; target : string
     ; alias : Alias.Name.t option
-    ; module_system : Melange.Module_system.t
+    ; module_systems : (Melange.Module_system.t * Filename.Extension.t) list
     ; modules : Stanza_common.Modules_settings.t
     ; libraries : Lib_dep.t list
     ; package : Package.t option
@@ -15,7 +15,6 @@ module Emit = struct
     ; promote : Rule.Promote.t option
     ; compile_flags : Ordered_set_lang.Unexpanded.t
     ; allow_overlapping_dependencies : bool
-    ; javascript_extension : string
     }
 
   type Stanza.t += T of t
@@ -51,14 +50,57 @@ module Emit = struct
     t
 
   let decode =
-    let extension_field name =
-      let+ loc, extension =
-        field name ~default:(Loc.none, "js") (located string)
-      in
+    let extension_field =
+      let+ loc, extension = located string in
       if String.is_prefix ~prefix:"." extension then
         User_error.raise ~loc [ Pp.textf "extension must not start with '.'" ];
       "." ^ extension
     in
+    let module_systems =
+      let module_system =
+        enum [ ("es6", Melange.Module_system.Es6); ("commonjs", CommonJs) ]
+      in
+      let+ module_systems =
+        repeat
+          (pair module_system (located extension_field)
+          <|> let+ loc, module_system = located module_system in
+              let _, ext = Melange.Module_system.default in
+              (module_system, (loc, ext)))
+      in
+
+      let module_systems =
+        match
+          String.Map.of_list_map module_systems ~f:(fun (ms, (loc, ext)) ->
+              (ext, (loc, ms)))
+        with
+        | Ok m -> String.Map.to_list_map m ~f:(fun ext (_loc, ms) -> (ms, ext))
+        | Error (ext, (_, (loc1, _)), (_, (loc2, _))) ->
+          let main_message =
+            Pp.textf "JavaScript extension %s appears more than once:" ext
+          in
+          let annots =
+            let main = User_message.make ~loc:loc2 [ main_message ] in
+            let related =
+              [ User_message.make ~loc:loc1 [ Pp.text "Already defined here" ] ]
+            in
+            User_message.Annots.singleton Compound_user_error.annot
+              [ Compound_user_error.make ~main ~related ]
+          in
+          User_error.raise ~annots ~loc:loc2
+            [ main_message
+            ; Pp.textf "- %s" (Loc.to_file_colon_line loc1)
+            ; Pp.textf "- %s" (Loc.to_file_colon_line loc2)
+            ; Pp.textf "Extensions must be unique per melange.emit stanza"
+            ]
+            ~hints:
+              [ Pp.textf
+                  "specify different extensions with (module_systems \
+                   (<system1> <extension1>) (<system2> <extension2>))"
+              ]
+      in
+
+      module_systems
+    in
     fields
       (let+ loc = loc
        and+ target =
@@ -81,16 +123,15 @@ module Emit = struct
          in
          field "target" (plain_string (fun ~loc s -> of_string ~loc s))
        and+ alias = field_o "alias" Alias.Name.decode
-       and+ module_system =
-         field "module_system"
-           (enum [ ("es6", Melange.Module_system.Es6); ("commonjs", CommonJs) ])
+       and+ module_systems =
+         field "module_systems" module_systems
+           ~default:[ Melange.Module_system.default ]
        and+ libraries = field "libraries" decode_lib ~default:[]
        and+ package = field_o "package" Stanza_common.Pkg.decode
        and+ preprocess, preprocessor_deps = Stanza_common.preprocess_fields
        and+ promote = field_o "promote" Rule_mode_decoder.Promote.decode
        and+ loc_instrumentation, instrumentation = Stanza_common.instrumentation
        and+ compile_flags = Ordered_set_lang.Unexpanded.field "compile_flags"
-       and+ javascript_extension = extension_field "javascript_extension"
        and+ allow_overlapping_dependencies =
          field_b "allow_overlapping_dependencies"
        and+ modules =
@@ -109,15 +150,14 @@ module Emit = struct
        { loc
        ; target
        ; alias
-       ; module_system
+       ; module_systems
        ; modules
        ; libraries
        ; package
        ; preprocess
        ; preprocessor_deps
        ; promote
        ; compile_flags
-       ; javascript_extension
        ; allow_overlapping_dependencies
        })
 end

src/dune_rules/melange/melange_stanzas.mli

@@ -6,7 +6,7 @@ module Emit : sig
     { loc : Loc.t
     ; target : string
     ; alias : Alias.Name.t option
-    ; module_system : Melange.Module_system.t
+    ; module_systems : (Melange.Module_system.t * string) list
     ; modules : Stanza_common.Modules_settings.t
     ; libraries : Lib_dep.t list
     ; package : Package.t option
@@ -15,7 +15,6 @@ module Emit : sig
     ; promote : Rule.Promote.t option
     ; compile_flags : Ordered_set_lang.Unexpanded.t
     ; allow_overlapping_dependencies : bool
-    ; javascript_extension : string
     }
 
   type Stanza.t += T of t

test/blackbox-tests/test-cases/melange/add-rules-under-melange-emit-target.t

@@ -8,8 +8,7 @@ Test that the target directory exists
   $ cat > dune <<EOF
   > (melange.emit
   >  (alias melange)
-  >  (target output)
-  >  (module_system commonjs))
+  >  (target output))
   > EOF
 
 Create the target dir
@@ -36,8 +35,7 @@ Target promotion works
   > (melange.emit
   >  (alias melange)
   >  (target output)
-  >  (promote (until-clean))
-  >  (module_system commonjs))
+  >  (promote (until-clean)))
   > EOF
 
   $ dune build @melange

test/blackbox-tests/test-cases/melange/aliases.t

@@ -8,8 +8,7 @@ Test (preprocess) field on melange.emit stanza
   $ cat > dune <<EOF
   > (melange.emit
   >  (target output)
-  >  (alias app)
-  >  (module_system commonjs))
+  >  (alias app))
   > EOF
 
   $ cat > main.ml <<EOF