Merge pull request #937 from rgrinberg/subsystem-versioned

Subsystem versioned

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)))
 

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 <lib>.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
     ]

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

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 =

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

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 <-

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
     }
 

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 () =

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. *)

src/usexp/loc.ml

@@ -16,3 +16,8 @@ let in_file fn =
   }
 
 let none = in_file "<none>"
+
+let of_lexbuf lexbuf : t =
+  { start = Lexing.lexeme_start_p lexbuf
+  ; stop  = Lexing.lexeme_end_p   lexbuf
+  }

src/usexp/loc.mli

@@ -6,3 +6,5 @@ type t =
 val in_file : string -> t
 
 val none : t
+
+val of_lexbuf : Lexing.lexbuf -> t

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
 

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

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))