refactor: Factor out common include file logic

Signed-off-by: Stephen Sherratt <[email protected]>

src/dune_rules/dune_file.ml

@@ -945,73 +945,22 @@ end
 
 module Install_conf = struct
   module File_entry = struct
-    type t =
-      | Binding of File_binding.Unexpanded.t
-      | Include of
-          { context : Univ_map.t
-          ; path : String_with_vars.t
-          }
+    include
+      Recursive_include.Make
+        (File_binding.Unexpanded)
+        (struct
+          let include_keyword = "include"
 
-    let decode =
-      let open Dune_lang.Decoder in
-      let decode_binding =
-        let+ binding = File_binding.Unexpanded.decode in
-        Binding binding
-      in
-      let decode_include =
-        sum
-          [ ( "include"
-            , let+ () = Syntax.since Stanza.syntax (3, 5)
-              and+ context = get_all
-              and+ path = String_with_vars.decode in
-              Include { context; path } )
-          ]
-      in
-      decode_binding <|> decode_include
+          let include_allowed_in_versions = `Since (3, 5)
 
-    let load_included_file path ~context =
-      let open Memo.O in
-      let+ contents =
-        Build_system.read_file (Path.build path) ~f:Io.read_file
-      in
-      let ast =
-        Dune_lang.Parser.parse_string contents ~mode:Single
-          ~fname:(Path.Build.to_string path)
-      in
-      let parse = Dune_lang.Decoder.parse decode context in
-      match ast with
-      | List (_loc, terms) -> List.map terms ~f:parse
-      | other ->
-        let loc = Dune_sexp.Ast.loc other in
-        User_error.raise ~loc [ Pp.textf "Expected list, got:\n%s" contents ]
-
-    let expand_include t ~expand_str ~dir =
-      let rec expand_include t ~seen =
-        match t with
-        | Binding binding -> Memo.return [ binding ]
-        | Include { context; path = path_sw } ->
-          let open Memo.O in
-          let* path =
-            expand_str path_sw
-            >>| Path.Build.relative
-                  ~error_loc:(String_with_vars.loc path_sw)
-                  dir
-          in
-          if Path.Build.Set.mem seen path then
-            User_error.raise
-              ~loc:(String_with_vars.loc path_sw)
-              [ Pp.textf "Include loop detected via: %s"
-                  (Path.Build.to_string path)
-              ];
-          let seen = Path.Build.Set.add seen path in
-          let* contents = load_included_file path ~context in
-          Memo.List.concat_map contents ~f:(expand_include ~seen)
-      in
-      expand_include t ~seen:Path.Build.Set.empty
+          let non_sexp_behaviour = `User_error
+        end)
 
     let expand_include_multi ts ~expand_str ~dir =
       Memo.List.concat_map ts ~f:(expand_include ~expand_str ~dir)
 
+    let of_file_binding = of_base
+
     let expand t ~expand_str ~dir =
       let open Memo.O in
       let* unexpanded = expand_include t ~expand_str ~dir in
@@ -1216,7 +1165,7 @@ module Executables = struct
           let files =
             List.map2 t.names public_names ~f:(fun (locn, name) (locp, pub) ->
                 Option.map pub ~f:(fun pub ->
-                    Install_conf.File_entry.Binding
+                    Install_conf.File_entry.of_file_binding
                       (File_binding.Unexpanded.make
                          ~src:(locn, name ^ ext)
                          ~dst:(locp, pub))))

src/dune_rules/foreign.ml

@@ -88,34 +88,40 @@ module Archive = struct
 end
 
 module Stubs = struct
-  module Include_dir = struct
+  module Include_dir_without_include = struct
     type t =
       | Dir of String_with_vars.t
       | Lib of Loc.t * Lib_name.t
-      | Include of
-          { context : Univ_map.t
-          ; path : String_with_vars.t
-          }
 
     let decode : t Dune_lang.Decoder.t =
       let open Dune_lang.Decoder in
       let parse_dir =
         let+ s = String_with_vars.decode in
         Dir s
       in
-      let parse_lib_or_include =
+      let parse_lib =
         sum
           [ ( "lib"
             , let+ loc, lib_name = located Lib_name.decode in
               Lib (loc, lib_name) )
-          ; ( "include"
-            , let+ () = Syntax.since Stanza.syntax (3, 5)
-              and+ context = get_all
-              and+ path = String_with_vars.decode in
-              Include { context; path } )
           ]
       in
-      parse_dir <|> parse_lib_or_include
+      parse_dir <|> parse_lib
+  end
+
+  module Include_dir = struct
+    include
+      Recursive_include.Make
+        (Include_dir_without_include)
+        (struct
+          let include_keyword = "include"
+
+          let include_allowed_in_versions = `Since (3, 5)
+
+          let non_sexp_behaviour = `Parse_as_base_term
+        end)
+
+    module Without_include = Include_dir_without_include
   end
 
   type t =

src/dune_rules/foreign.mli

@@ -77,15 +77,21 @@ module Stubs : sig
   (* Foreign sources can depend on a directly specified directory [Dir] or on a
      source directory of a library [Lib]. *)
   module Include_dir : sig
-    type t =
-      | Dir of String_with_vars.t
-      | Lib of Loc.t * Lib_name.t
-      | Include of
-          { context : Univ_map.t
-          ; path : String_with_vars.t
-          }
+    module Without_include : sig
+      type t =
+        | Dir of String_with_vars.t
+        | Lib of Loc.t * Lib_name.t
+    end
+
+    type t
 
     val decode : t Dune_lang.Decoder.t
+
+    val expand_include :
+         t
+      -> expand_str:(String_with_vars.t -> string Memo.t)
+      -> dir:Path.Build.t
+      -> Without_include.t list Memo.t
   end
 
   type t =

src/dune_rules/foreign_rules.ml

@@ -8,61 +8,6 @@ module Source_tree_map_reduce =
       type t = Command.Args.without_targets Command.Args.t
     end))
 
-module Include_dir_expanded = struct
-  (* An [Include_dir.t] without the [Include] constructor *)
-  type t =
-    | Dir of String_with_vars.t
-    | Lib of Loc.t * Lib_name.t
-
-  type include_t =
-    { context : Univ_map.t
-    ; path : String_with_vars.t
-    }
-
-  let of_include_dir include_dir =
-    match (include_dir : Foreign.Stubs.Include_dir.t) with
-    | Dir d -> Right (Dir d)
-    | Lib (loc, lib_name) -> Right (Lib (loc, lib_name))
-    | Include { context; path } -> Left { context; path }
-end
-
-(* Recursively expand all the (include ...) terms in an [Include_dir.t], returning
-   a list of [Include_dir_expanded.t] *)
-let expand_include_dir ~expander include_dir =
-  (* Parse a file at a specified path as a list of [Include_dir.t]s *)
-  let parse_include_dirs_file ~context path =
-    let open Action_builder.O in
-    let+ ast = Action_builder.read_sexp path in
-    let parse_single ast =
-      Dune_lang.Decoder.parse Foreign.Stubs.Include_dir.decode context ast
-    in
-    (* If the file contains a sexp list, parse each element of the list as an
-       [Include_dir.t].
-       Otherwise parse the entire file's contents as a single [Include_dir.t].
-    *)
-    match (ast : Dune_lang.Ast.t) with
-    | List (_loc, terms) -> List.map terms ~f:parse_single
-    | other -> [ parse_single other ]
-  in
-  let rec expand_include_dir ~seen include_dir =
-    match Include_dir_expanded.of_include_dir include_dir with
-    | Right include_dir_expanded ->
-      Action_builder.return [ include_dir_expanded ]
-    | Left { context; path } ->
-      expand_include_dir_include_statement ~seen ~context path
-  and expand_include_dir_include_statement ~seen ~context path_sw =
-    let open Action_builder.O in
-    let* path = Expander.expand_path expander path_sw in
-    if Path.Set.mem seen path then
-      User_error.raise
-        ~loc:(String_with_vars.loc path_sw)
-        [ Pp.textf "Include loop detected via: %s" (Path.to_string path) ];
-    let seen = Path.Set.add seen path in
-    let* include_dirs = parse_include_dirs_file ~context path in
-    Action_builder.List.concat_map include_dirs ~f:(expand_include_dir ~seen)
-  in
-  expand_include_dir ~seen:Path.Set.empty include_dir
-
 (* Compute command line flags for the [include_dirs] field of [Foreign.Stubs.t]
    and track all files in specified directories as [Hidden_deps]
    dependencies. *)
@@ -77,7 +22,7 @@ let include_dir_flags ~expander ~dir (stubs : Foreign.Stubs.t) =
     Resolve.Memo.args
       (let open Resolve.Memo.O in
       let+ loc, include_dir =
-        match (include_dir : Include_dir_expanded.t) with
+        match (include_dir : Foreign.Stubs.Include_dir.Without_include.t) with
         | Dir dir ->
           Resolve.Memo.return
             (String_with_vars.loc dir, Expander.expand_path expander dir)
@@ -161,8 +106,10 @@ let include_dir_flags ~expander ~dir (stubs : Foreign.Stubs.t) =
   Command.Args.Dyn
     (let open Action_builder.O in
     let+ include_dirs_expanded =
-      Action_builder.List.concat_map stubs.include_dirs
-        ~f:(expand_include_dir ~expander)
+      let expand_str = Expander.No_deps.expand_str expander in
+      Memo.List.concat_map stubs.include_dirs
+        ~f:(Foreign.Stubs.Include_dir.expand_include ~expand_str ~dir)
+      |> Action_builder.of_memo
     in
     Command.Args.S (List.map include_dirs_expanded ~f:args_of_include_dir))
 

src/dune_rules/recursive_include.ml

@@ -0,0 +1,98 @@
+open! Import
+
+module Include_term = struct
+  type t =
+    { context : Univ_map.t
+    ; path : String_with_vars.t
+    }
+
+  let decode ~include_keyword ~allowed_in_versions =
+    let open Dune_lang.Decoder in
+    let version_check () =
+      match allowed_in_versions with
+      | `Since version -> Syntax.since Stanza.syntax version
+      | `All -> return ()
+    in
+    sum
+      [ ( include_keyword
+        , let+ () = version_check ()
+          and+ context = get_all
+          and+ path = String_with_vars.decode in
+          { context; path } )
+      ]
+end
+
+module Make (Base_term : sig
+  type t
+
+  val decode : t Dune_lang.Decoder.t
+end) (Config : sig
+  val include_keyword : string
+
+  val include_allowed_in_versions : [ `Since of Syntax.Version.t | `All ]
+
+  val non_sexp_behaviour : [ `User_error | `Parse_as_base_term ]
+end) =
+struct
+  type t =
+    | Base of Base_term.t
+    | Include of Include_term.t
+
+  let of_base base = Base base
+
+  let decode =
+    let open Dune_lang.Decoder in
+    let base_term_decode =
+      let+ base_term = Base_term.decode in
+      Base base_term
+    in
+    let include_term_decode =
+      let+ include_term =
+        Include_term.decode ~include_keyword:Config.include_keyword
+          ~allowed_in_versions:Config.include_allowed_in_versions
+      in
+      Include include_term
+    in
+    include_term_decode <|> base_term_decode
+
+  let load_included_file path ~context =
+    let open Memo.O in
+    let+ contents = Build_system.read_file (Path.build path) ~f:Io.read_file in
+    let ast =
+      Dune_lang.Parser.parse_string contents ~mode:Single
+        ~fname:(Path.Build.to_string path)
+    in
+    let parse = Dune_lang.Decoder.parse decode context in
+    match ast with
+    | List (_loc, terms) -> List.map terms ~f:parse
+    | other -> (
+      match Config.non_sexp_behaviour with
+      | `User_error ->
+        let loc = Dune_sexp.Ast.loc other in
+        User_error.raise ~loc [ Pp.textf "Expected list, got:\n%s" contents ]
+      | `Parse_as_base_term ->
+        let term = Dune_lang.Decoder.parse decode context other in
+        [ term ])
+
+  let expand_include t ~expand_str ~dir =
+    let rec expand_include t ~seen =
+      match t with
+      | Base base_term -> Memo.return [ base_term ]
+      | Include { context; path = path_sw } ->
+        let open Memo.O in
+        let* path =
+          expand_str path_sw
+          >>| Path.Build.relative ~error_loc:(String_with_vars.loc path_sw) dir
+        in
+        if Path.Build.Set.mem seen path then
+          User_error.raise
+            ~loc:(String_with_vars.loc path_sw)
+            [ Pp.textf "Include loop detected via: %s"
+                (Path.Build.to_string path)
+            ];
+        let seen = Path.Build.Set.add seen path in
+        let* contents = load_included_file path ~context in
+        Memo.List.concat_map contents ~f:(expand_include ~seen)
+    in
+    expand_include t ~seen:Path.Build.Set.empty
+end