Process (include ...) before (subdir ...)

Signed-off-by: Nicolás Ojeda Bär <[email protected]>

src/dune/dune_file.ml

@@ -13,13 +13,6 @@ module Jbuild_version = struct
   let decode = enum [ ("1", V1) ]
 end
 
-let relative_file =
-  plain_string (fun ~loc fn ->
-      if Filename.is_relative fn then
-        fn
-      else
-        User_error.raise ~loc [ Pp.textf "relative filename expected" ])
-
 let () =
   Dune_project.Extension.register_deleted ~name:"library_variants"
     ~deleted_in:(2, 6)
@@ -1977,60 +1970,19 @@ module Stanzas = struct
     let parser = parser project in
     parse parser sexp
 
-  exception Include_loop of Path.Source.t * (Loc.t * Path.Source.t) list
-
-  let rec parse_file_includes ~stanza_parser ~lexer ~current_file ~include_stack
-      sexps =
+  let rec parse_file_includes ~stanza_parser ~context sexps =
     List.concat_map sexps ~f:(parse stanza_parser)
     |> List.concat_map ~f:(function
          | Include (loc, fn) ->
-           let include_stack = (loc, current_file) :: include_stack in
-           let dir = Path.Source.parent_exn current_file in
-           let current_file = Path.Source.relative dir fn in
-           if not (Path.exists (Path.source current_file)) then
-             User_error.raise ~loc
-               [ Pp.textf "File %s doesn't exist."
-                   (Path.Source.to_string_maybe_quoted current_file)
-               ];
-           if
-             List.exists include_stack ~f:(fun (_, f) ->
-                 Path.Source.equal f current_file)
-           then
-             raise (Include_loop (current_file, include_stack));
-           let sexps =
-             Dune_lang.Parser.load ~lexer (Path.source current_file) ~mode:Many
-           in
-           parse_file_includes ~stanza_parser ~lexer ~current_file
-             ~include_stack sexps
+           let sexps, context = Include.load_sexps ~context (loc, fn) in
+           parse_file_includes ~stanza_parser ~context sexps
          | stanza -> [ stanza ])
 
   let parse ~file (project : Dune_project.t) sexps =
     let stanza_parser = parser project in
-    let lexer = Dune_lang.Lexer.token in
     let stanzas =
-      try
-        parse_file_includes ~stanza_parser ~lexer ~include_stack:[]
-          ~current_file:file sexps
-      with
-      | Include_loop (_, []) -> assert false
-      | Include_loop (file, last :: rest) ->
-        let loc = fst (Option.value (List.last rest) ~default:last) in
-        let line_loc (loc, file) =
-          sprintf "%s:%d"
-            (Path.Source.to_string_maybe_quoted file)
-            loc.Loc.start.pos_lnum
-        in
-        User_error.raise ~loc
-          [ Pp.text "Recursive inclusion of dune files detected:"
-          ; Pp.textf "File %s is included from %s"
-              (Path.Source.to_string_maybe_quoted file)
-              (line_loc last)
-          ; Pp.vbox
-              (Pp.concat_map rest ~sep:Pp.cut ~f:(fun x ->
-                   Pp.box ~indent:3
-                     (Pp.seq (Pp.verbatim "-> ")
-                        (Pp.textf "included from %s" (line_loc x)))))
-          ]
+      let context = Include.in_file file in
+      parse_file_includes ~stanza_parser ~context sexps
     in
     match
       List.filter_map stanzas ~f:(function

src/dune/file_tree.ml

@@ -78,8 +78,10 @@ module Dune_file = struct
     | None -> Sub_dirs.default
     | Some t -> Sub_dirs.or_default t.plain.contents.subdir_status
 
-  let load_plain sexps ~from_parent ~project =
-    let decoder = Dune_project.set_parsing_context project Sub_dirs.decode in
+  let load_plain sexps ~file ~from_parent ~project =
+    let decoder =
+      Dune_project.set_parsing_context project (Sub_dirs.decode ~file)
+    in
     let active =
       let parsed =
         Dune_lang.Decoder.parse decoder Univ_map.empty
@@ -95,15 +97,15 @@ module Dune_file = struct
   let load file ~file_exists ~from_parent ~project =
     let kind, plain =
       match file_exists with
-      | false -> (Plain, load_plain [] ~from_parent ~project)
+      | false -> (Plain, load_plain [] ~file ~from_parent ~project)
       | true ->
         Io.with_lexbuf_from_file (Path.source file) ~f:(fun lb ->
             if Dune_lexer.is_script lb then
-              let from_parent = load_plain [] ~from_parent ~project in
+              let from_parent = load_plain [] ~file ~from_parent ~project in
               (Ocaml_script, from_parent)
             else
               let sexps = Dune_lang.Parser.parse lb ~mode:Many in
-              (Plain, load_plain sexps ~from_parent ~project))
+              (Plain, load_plain sexps ~file ~from_parent ~project))
     in
     { path = file; kind; plain }
 end

src/dune/stanza_common.ml

@@ -99,3 +99,56 @@ module Pkg = struct
 end
 
 let modules_field name = Ordered_set_lang.field name
+
+module Include = struct
+  type context =
+    { current_file : Path.Source.t
+    ; include_stack : (Loc.t * Path.Source.t) list
+    }
+
+  let in_file file = { current_file = file; include_stack = [] }
+
+  let error { current_file = file; include_stack } =
+    let last, rest =
+      match include_stack with
+      | [] -> assert false
+      | last :: rest -> (last, rest)
+    in
+    let loc = fst (Option.value (List.last rest) ~default:last) in
+    let line_loc (loc, file) =
+      sprintf "%s:%d"
+        (Path.Source.to_string_maybe_quoted file)
+        loc.Loc.start.pos_lnum
+    in
+    User_error.raise ~loc
+      [ Pp.text "Recursive inclusion of dune files detected:"
+      ; Pp.textf "File %s is included from %s"
+          (Path.Source.to_string_maybe_quoted file)
+          (line_loc last)
+      ; Pp.vbox
+          (Pp.concat_map rest ~sep:Pp.cut ~f:(fun x ->
+               Pp.box ~indent:3
+                 (Pp.seq (Pp.verbatim "-> ")
+                    (Pp.textf "included from %s" (line_loc x)))))
+      ]
+
+  let load_sexps ~context:{ current_file; include_stack } (loc, fn) =
+    let include_stack = (loc, current_file) :: include_stack in
+    let dir = Path.Source.parent_exn current_file in
+    let current_file = Path.Source.relative dir fn in
+    if not (Path.exists (Path.source current_file)) then
+      User_error.raise ~loc
+        [ Pp.textf "File %s doesn't exist."
+            (Path.Source.to_string_maybe_quoted current_file)
+        ];
+    if
+      List.exists include_stack ~f:(fun (_, f) ->
+          Path.Source.equal f current_file)
+    then
+      error { current_file; include_stack };
+    let sexps =
+      Dune_lang.Parser.load ~lexer:Dune_lang.Lexer.token
+        (Path.source current_file) ~mode:Many
+    in
+    (sexps, { current_file; include_stack })
+end

src/dune/stanza_common.mli

@@ -12,3 +12,12 @@ module Pkg : sig
 end
 
 val modules_field : string -> Ordered_set_lang.t Dune_lang.Decoder.fields_parser
+
+module Include : sig
+  type context
+
+  val in_file : Path.Source.t -> context
+
+  val load_sexps :
+    context:context -> Loc.t * string -> Dune_lang.Ast.t list * context
+end

src/dune/sub_dirs.ml

@@ -304,3 +304,34 @@ let decode =
          Dir_map.singleton { Dir_map.sexps = rest; subdir_status } :: subdirs)
   in
   enter (fields (decode ~allow_ignored_subdirs:true))
+
+let decode_includes ~context =
+  let open Dune_lang.Decoder in
+  let rec subdir ~context =
+    let* loc = loc in
+    let* name =
+      plain_string (fun ~loc s -> Atom (loc, Dune_lang.Atom.of_string s))
+    in
+    let+ nodes = fields (decode ~context) in
+    List
+      (loc, Atom (Loc.none, Dune_lang.Atom.of_string "subdir") :: name :: nodes)
+  and decode ~context =
+    let* includes =
+      multi_field "include"
+        (let* loc = loc
+         and+ fn = relative_file in
+         let sexps, context =
+           Stanza_common.Include.load_sexps ~context (loc, fn)
+         in
+         fields (with_input sexps (decode ~context)))
+    in
+    let+ subdirs = multi_field "subdir" (subdir ~context)
+    and+ sexps = leftover_fields in
+    List.concat (sexps :: subdirs :: includes)
+  in
+  enter (fields (decode ~context))
+
+let decode ~file =
+  let open Dune_lang.Decoder in
+  let* sexps = decode_includes ~context:(Stanza_common.Include.in_file file) in
+  with_input [ List (Loc.none, sexps) ] decode

src/dune/sub_dirs.mli

@@ -69,4 +69,4 @@ module Dir_map : sig
   val root : t -> per_dir
 end
 
-val decode : Dir_map.t Dune_lang.Decoder.t
+val decode : file:Path.Source.t -> Dir_map.t Dune_lang.Decoder.t

src/dune_lang/decoder.ml

@@ -184,6 +184,35 @@ let parse t context sexp =
   let ctx = Values (Ast.loc sexp, None, context) in
   result ctx (t ctx [ sexp ])
 
+let fields_of_values sexps =
+  let unparsed =
+    List.fold_left sexps ~init:Name.Map.empty ~f:(fun acc sexp ->
+        match sexp with
+        | List (_, name_sexp :: values) -> (
+          match name_sexp with
+          | Atom (_, A name) ->
+            Name.Map.set acc name
+              { Fields.Unparsed.values
+              ; entry = sexp
+              ; prev = Name.Map.find acc name
+              }
+          | List (loc, _)
+          | Quoted_string (loc, _)
+          | Template { loc; _ } ->
+            User_error.raise ~loc [ Pp.text "Atom expected" ] )
+        | _ ->
+          User_error.raise ~loc:(Ast.loc sexp)
+            [ Pp.text "S-expression of the form (<name> <values>...) expected" ])
+  in
+  { Fields.unparsed; known = [] }
+
+let with_input : type a k. ast list -> (a, k) parser -> k context -> k -> a * k
+    =
+ fun sexps t context _ ->
+  match context with
+  | Values _ -> t context sexps
+  | Fields _ -> t context (fields_of_values sexps)
+
 let capture ctx state =
   let f t = result ctx (t ctx state) in
   (f, [])
@@ -273,6 +302,13 @@ let filename =
           [ Pp.textf "'.' and '..' are not valid filenames" ]
       | fn -> fn)
 
+let relative_file =
+  plain_string (fun ~loc fn ->
+      if Filename.is_relative fn then
+        fn
+      else
+        User_error.raise ~loc [ Pp.textf "relative filename expected" ])
+
 let enter t =
   next_with_user_context (fun uc sexp ->
       match sexp with
@@ -577,27 +613,8 @@ let multi_field name t (Fields (_, _, uc)) (state : Fields.t) =
   (res, Fields.consume name state)
 
 let fields t (Values (loc, cstr, uc)) sexps =
-  let unparsed =
-    List.fold_left sexps ~init:Name.Map.empty ~f:(fun acc sexp ->
-        match sexp with
-        | List (_, name_sexp :: values) -> (
-          match name_sexp with
-          | Atom (_, A name) ->
-            Name.Map.set acc name
-              { Fields.Unparsed.values
-              ; entry = sexp
-              ; prev = Name.Map.find acc name
-              }
-          | List (loc, _)
-          | Quoted_string (loc, _)
-          | Template { loc; _ } ->
-            User_error.raise ~loc [ Pp.text "Atom expected" ] )
-        | _ ->
-          User_error.raise ~loc:(Ast.loc sexp)
-            [ Pp.text "S-expression of the form (<name> <values>...) expected" ])
-  in
   let ctx = Fields (loc, cstr, uc) in
-  let x = result ctx (t ctx { Fields.unparsed; known = [] }) in
+  let x = result ctx (t ctx (fields_of_values sexps)) in
   (x, [])
 
 let leftover_fields_generic t more_fields (Fields (loc, cstr, uc)) state =

src/dune_lang/decoder.mli

@@ -47,6 +47,8 @@ type 'a fields_parser = ('a, fields) parser
     information such as versions to individual parsers. *)
 val parse : 'a t -> Univ_map.t -> ast -> 'a
 
+val with_input : ast list -> ('a, 'k) parser -> ('a, 'k) parser
+
 val return : 'a -> ('a, _) parser
 
 val ( >>= ) : ('a, 'k) parser -> ('a -> ('b, 'k) parser) -> ('b, 'k) parser
@@ -170,6 +172,9 @@ val plain_string : (loc:Loc.t -> string -> 'a) -> 'a t
 (** A valid filename, i.e. a string other than "." or ".." *)
 val filename : string t
 
+(** A relative filename *)
+val relative_file : string t
+
 val fix : ('a t -> 'a t) -> 'a t
 
 val located : ('a, 'k) parser -> (Loc.t * 'a, 'k) parser