diff --git a/src/install_rules.ml b/src/install_rules.ml index 44625876..efe4afbf 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -39,8 +39,11 @@ module Gen(P : Install_params) = struct let gen_lib_dune_file lib = SC.add_rule sctx (Build.arr (fun () -> - Format.asprintf "%a@." (Sexp.pp Dune) - (Lib.Sub_system.dump_config lib |> Installed_dune_file.gen)) + let dune_version = Option.value_exn (Lib.dune_version lib) in + Format.asprintf "%a@." + (Sexp.pp (Stanza.File_kind.of_syntax dune_version)) + (Lib.Sub_system.dump_config lib + |> Installed_dune_file.gen ~dune_version)) >>> Build.write_file_dyn (lib_dune_file ~dir:(Lib.src_dir lib) ~name:(Lib.name lib))) diff --git a/src/installed_dune_file.ml b/src/installed_dune_file.ml index ab7535cc..c8bfae70 100644 --- a/src/installed_dune_file.ml +++ b/src/installed_dune_file.ml @@ -1,10 +1,10 @@ open Import -let parse_sub_systems sexps = +let parse_sub_systems ~parsing_context sexps = List.filter_map sexps ~f:(fun sexp -> let name, ver, data = Sexp.Of_sexp.(parse (triple string (located Syntax.Version.t) raw) - Univ_map.empty) sexp + parsing_context) sexp in match Sub_system_name.get name with | None -> @@ -22,9 +22,15 @@ let parse_sub_systems sexps = let (module M) = Jbuild.Sub_system_info.get name in Syntax.check_supported M.syntax version; let parsing_context = - Univ_map.singleton (Syntax.key M.syntax) - (* This is wrong, see #909 *) - (0, 0) + (* We set the syntax to the version used when generating this subsystem. + We cannot do this for jbuild defined subsystems however since those use + 1.0 as the version. Which would correspond to the dune syntax (because + subsystems share the syntax of the dune lang) *) + match Univ_map.find_exn parsing_context (Syntax.key Stanza.syntax) with + | (0, 0) -> + parsing_context + | (_, _) -> + Univ_map.add parsing_context (Syntax.key M.syntax) (snd version) in M.T (Sexp.Of_sexp.parse M.parse parsing_context data)) @@ -32,22 +38,53 @@ let of_sexp = let open Sexp.Of_sexp in let version = plain_string (fun ~loc -> function - | "1" -> () - | _ -> + | "1" -> (0, 0) + | "2" -> (1, 0) + | v -> of_sexp_errorf loc - "Unsupported version, only version 1 is supported") + "Unsupported version %S, only version 1 is supported" v) in sum [ "dune", - (version >>= fun () -> - list raw >>| fun l -> - parse_sub_systems l) + (version >>= fun version -> + set (Syntax.key Stanza.syntax) version + (get_all >>= fun parsing_context -> + list raw >>| + parse_sub_systems ~parsing_context)) ] let load fname = - Sexp.Of_sexp.parse of_sexp Univ_map.empty (Io.Sexp.load ~mode:Single fname) + Io.with_lexbuf_from_file fname ~f:(fun lexbuf -> + (* Installed dune files are versioned but they don't use the + [(lang ...)] line which was introduced after. Installed dune + files in version 1 are using the jbuild syntax and version 2 + are using the dune syntax, so we start by lexing the first + tokens with the dune lexer until we reach the file version, at + which point we can decide what lexer to use for the reset of + the file. *) + let state = ref 0 in + let lexer = ref Sexp.Lexer.token in + let lexer lb = + let token : Sexp.Lexer.Token.t = !lexer lb in + (match !state, token with + | 0, Lparen -> state := 1 + | 1, Atom (A "dune") -> state := 2 + | 2, Atom (A "1") -> state := 3; lexer := Sexp.Lexer.jbuild_token + | 2, Atom (A "2") -> state := 3; lexer := Sexp.Lexer.token + | 2, Atom (A version) -> + Loc.fail (Sexp.Loc.of_lexbuf lexbuf) "Unsupported version %S" version + | 3, _ -> () + | _ -> + Loc.fail (Sexp.Loc.of_lexbuf lexbuf) + "This .dune file looks invalid, it should \ + contain a S-expression of the form (dune x.y ..)" + ); + token + in + Sexp.Of_sexp.parse of_sexp Univ_map.empty + (Sexp.Parser.parse ~lexer ~mode:Single lexbuf)) -let gen confs = +let gen ~(dune_version : Syntax.Version.t) confs = let sexps = Sub_system_name.Map.to_list confs |> List.map ~f:(fun (name, (ver, conf)) -> @@ -59,6 +96,12 @@ let gen confs = in Sexp.List [ Sexp.unsafe_atom_of_string "dune" - ; Sexp.unsafe_atom_of_string "1" + ; Sexp.unsafe_atom_of_string + (match dune_version with + | (0, 0) -> "1" + | (x, _) when x >= 1 -> "2" + | (_, _) -> + Exn.code_error "Cannot generate dune with unknown version" + ["dune_version", Syntax.Version.sexp_of_t dune_version]) ; List sexps ] diff --git a/src/installed_dune_file.mli b/src/installed_dune_file.mli index d498cb00..a82abb8e 100644 --- a/src/installed_dune_file.mli +++ b/src/installed_dune_file.mli @@ -3,4 +3,7 @@ open Stdune val load : Path.t -> Jbuild.Sub_system_info.t Sub_system_name.Map.t -val gen : (Syntax.Version.t * Sexp.t) Sub_system_name.Map.t -> Sexp.t +val gen + : dune_version:Syntax.Version.t + -> (Syntax.Version.t * Sexp.t) Sub_system_name.Map.t + -> Sexp.t diff --git a/src/jbuild.ml b/src/jbuild.ml index 9a2c780d..612f4c59 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -732,6 +732,7 @@ module Library = struct ; project : Dune_project.t ; sub_systems : Sub_system_info.t Sub_system_name.Map.t ; no_keep_locs : bool + ; dune_version : Syntax.Version.t } let t = @@ -763,6 +764,7 @@ module Library = struct field_b "no_keep_locs" >>= fun no_keep_locs -> Sub_system_info.record_parser () >>= fun sub_systems -> Dune_project.get_exn () >>= fun project -> + Syntax.get_exn Stanza.syntax >>= fun dune_version -> return { name ; public @@ -786,6 +788,7 @@ module Library = struct ; project ; sub_systems ; no_keep_locs + ; dune_version }) let has_stubs t = diff --git a/src/jbuild.mli b/src/jbuild.mli index e9048140..82174b7a 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -206,6 +206,7 @@ module Library : sig ; project : Dune_project.t ; sub_systems : Sub_system_info.t Sub_system_name.Map.t ; no_keep_locs : bool + ; dune_version : Syntax.Version.t } val has_stubs : t -> bool diff --git a/src/lib.ml b/src/lib.ml index 71f584d6..d11f8f67 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -63,6 +63,7 @@ module Info = struct ; pps : (Loc.t * Jbuild.Pp.t) list ; optional : bool ; virtual_deps : (Loc.t * string) list + ; dune_version : Syntax.Version.t option ; sub_systems : Jbuild.Sub_system_info.t Sub_system_name.Map.t } @@ -114,6 +115,7 @@ module Info = struct ; ppx_runtime_deps = conf.ppx_runtime_libraries ; pps = Jbuild.Preprocess_map.pps conf.buildable.preprocess ; sub_systems = conf.sub_systems + ; dune_version = Some conf.dune_version } let of_findlib_package pkg = @@ -143,6 +145,7 @@ module Info = struct ; (* We don't know how these are named for external libraries *) foreign_archives = Mode.Dict.make_both [] ; sub_systems = sub_systems + ; dune_version = None } end @@ -237,6 +240,7 @@ type t = ; resolved_selects : Resolved_select.t list ; optional : bool ; user_written_deps : Jbuild.Lib_deps.t + ; dune_version : Syntax.Version.t option ; (* This is mutable to avoid this error: {[ @@ -343,6 +347,8 @@ let plugins t = t.plugins let jsoo_runtime t = t.jsoo_runtime let unique_id t = t.unique_id +let dune_version t = t.dune_version + let src_dir t = t.src_dir let obj_dir t = t.obj_dir @@ -508,9 +514,7 @@ module Sub_system = struct let dump_config lib = Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun (lazy inst) -> let (Sub_system0.Instance.T ((module M), t)) = inst in - match M.to_sexp with - | None -> None - | Some f -> Some (f t)) + Option.map ~f:(fun f -> f t) M.to_sexp) end (* +-----------------------------------------------------------------+ @@ -664,6 +668,7 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden = ; optional = info.optional ; user_written_deps = Info.user_written_deps info ; sub_systems = Sub_system_name.Map.empty + ; dune_version = info.dune_version } in t.sub_systems <- diff --git a/src/lib.mli b/src/lib.mli index d70ef8c9..b50a4a7c 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -26,6 +26,8 @@ val archives : t -> Path.t list Mode.Dict.t val plugins : t -> Path.t list Mode.Dict.t val jsoo_runtime : t -> Path.t list +val dune_version : t -> Syntax.Version.t option + (** A unique integer identifier. It is only unique for the duration of the process *) val unique_id : t -> int @@ -103,6 +105,7 @@ module Info : sig ; pps : (Loc.t * Jbuild.Pp.t) list ; optional : bool ; virtual_deps : (Loc.t * string) list + ; dune_version : Syntax.Version.t option ; sub_systems : Jbuild.Sub_system_info.t Sub_system_name.Map.t } diff --git a/src/stanza.ml b/src/stanza.ml index b6166c8f..c7744586 100644 --- a/src/stanza.ml +++ b/src/stanza.ml @@ -13,7 +13,11 @@ let syntax = ] module File_kind = struct - type t = Jbuild | Dune + type t = Sexp.syntax = Jbuild | Dune + + let of_syntax = function + | (0, _) -> Jbuild + | (_, _) -> Dune end let file_kind () = diff --git a/src/stanza.mli b/src/stanza.mli index 5377360b..1934f06b 100644 --- a/src/stanza.mli +++ b/src/stanza.mli @@ -18,7 +18,9 @@ end val syntax : Syntax.t module File_kind : sig - type t = Jbuild | Dune + type t = Sexp.syntax = Jbuild | Dune + + val of_syntax : Syntax.Version.t -> t end (** Whether we are parsing a [jbuild] or [dune] file. *) diff --git a/src/usexp/loc.ml b/src/usexp/loc.ml index d7ac4844..54c9aeac 100644 --- a/src/usexp/loc.ml +++ b/src/usexp/loc.ml @@ -16,3 +16,8 @@ let in_file fn = } let none = in_file "" + +let of_lexbuf lexbuf : t = + { start = Lexing.lexeme_start_p lexbuf + ; stop = Lexing.lexeme_end_p lexbuf + } diff --git a/src/usexp/loc.mli b/src/usexp/loc.mli index 514f3a68..2526948e 100644 --- a/src/usexp/loc.mli +++ b/src/usexp/loc.mli @@ -6,3 +6,5 @@ type t = val in_file : string -> t val none : t + +val of_lexbuf : Lexing.lexbuf -> t diff --git a/src/usexp/usexp.ml b/src/usexp/usexp.ml index 3681098a..b687686e 100644 --- a/src/usexp/usexp.ml +++ b/src/usexp/usexp.ml @@ -166,11 +166,6 @@ module Parser = struct ; message }) - let make_loc lexbuf : Loc.t = - { start = Lexing.lexeme_start_p lexbuf - ; stop = Lexing.lexeme_end_p lexbuf - } - module Mode = struct type 'a t = | Single : Ast.t t @@ -183,7 +178,7 @@ module Parser = struct | Single -> begin match sexps with | [sexp] -> sexp - | [] -> error (make_loc lexbuf) "no s-expression found in input" + | [] -> error (Loc.of_lexbuf lexbuf) "no s-expression found in input" | _ :: sexp :: _ -> error (Ast.loc sexp) "too many s-expressions found in input" end @@ -200,13 +195,13 @@ module Parser = struct let rec loop depth lexer lexbuf acc = match (lexer lexbuf : Lexer.Token.t) with | Atom a -> - let loc = make_loc lexbuf in + let loc = Loc.of_lexbuf lexbuf in loop depth lexer lexbuf (Ast.Atom (loc, a) :: acc) | Quoted_string s -> - let loc = make_loc lexbuf in + let loc = Loc.of_lexbuf lexbuf in loop depth lexer lexbuf (Quoted_string (loc, s) :: acc) | Template t -> - let loc = make_loc lexbuf in + let loc = Loc.of_lexbuf lexbuf in loop depth lexer lexbuf (Template { t with loc } :: acc) | Lparen -> let start = Lexing.lexeme_start_p lexbuf in @@ -215,12 +210,12 @@ module Parser = struct loop depth lexer lexbuf (List ({ start; stop }, sexps) :: acc) | Rparen -> if depth = 0 then - error (make_loc lexbuf) + error (Loc.of_lexbuf lexbuf) "right parenthesis without matching left parenthesis"; List.rev acc | Sexp_comment -> let sexps = - let loc = make_loc lexbuf in + let loc = Loc.of_lexbuf lexbuf in match loop depth lexer lexbuf [] with | _ :: sexps -> sexps | [] -> error loc "s-expression missing after #;" @@ -228,7 +223,7 @@ module Parser = struct List.rev_append acc sexps | Eof -> if depth > 0 then - error (make_loc lexbuf) + error (Loc.of_lexbuf lexbuf) "unclosed parenthesis at end of input"; List.rev acc diff --git a/src/usexp/usexp.mli b/src/usexp/usexp.mli index f6c55388..bc0ad768 100644 --- a/src/usexp/usexp.mli +++ b/src/usexp/usexp.mli @@ -28,6 +28,8 @@ module Loc : sig val in_file : string -> t val none : t + + val of_lexbuf : Lexing.lexbuf -> t end module Template : sig @@ -112,7 +114,18 @@ end exception Parse_error of Parse_error.t module Lexer : sig - type t + module Token : sig + type t = + | Atom of Atom.t + | Quoted_string of string + | Lparen + | Rparen + | Sexp_comment + | Eof + | Template of Template.t + end + + type t = Lexing.lexbuf -> Token.t val token : t val jbuild_token : t diff --git a/test/blackbox-tests/test-cases/inline_tests/run.t b/test/blackbox-tests/test-cases/inline_tests/run.t index 3646e4ae..d46693c7 100644 --- a/test/blackbox-tests/test-cases/inline_tests/run.t +++ b/test/blackbox-tests/test-cases/inline_tests/run.t @@ -22,7 +22,7 @@ $ dune runtest dune-file (dune - 1 + 2 ((inline_tests.backend 1.0 ((runner_libraries (str))