From 3874bbfd8a92c7abb68f4d29ff04d2340ee74905 Mon Sep 17 00:00:00 2001 From: Stephen Sherratt Date: Tue, 11 Oct 2022 19:35:04 +1100 Subject: [PATCH] Factor out common include file logic Signed-off-by: Stephen Sherratt --- src/dune_rules/dune_file.ml | 73 +++---------------- src/dune_rules/foreign.ml | 30 ++++---- src/dune_rules/foreign.mli | 20 ++++-- src/dune_rules/foreign_rules.ml | 63 ++--------------- src/dune_rules/recursive_include.ml | 101 +++++++++++++++++++++++++++ src/dune_rules/recursive_include.mli | 54 ++++++++++++++ 6 files changed, 202 insertions(+), 139 deletions(-) create mode 100644 src/dune_rules/recursive_include.ml create mode 100644 src/dune_rules/recursive_include.mli diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index 838b2478339a..a84700b91416 100644 --- a/src/dune_rules/dune_file.ml +++ b/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)))) diff --git a/src/dune_rules/foreign.ml b/src/dune_rules/foreign.ml index e6916676e1f3..50cdb4a4b6ee 100644 --- a/src/dune_rules/foreign.ml +++ b/src/dune_rules/foreign.ml @@ -88,14 +88,10 @@ 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 @@ -103,19 +99,29 @@ module Stubs = struct 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 = diff --git a/src/dune_rules/foreign.mli b/src/dune_rules/foreign.mli index b205032d7686..60a0f8a5f2a4 100644 --- a/src/dune_rules/foreign.mli +++ b/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 = diff --git a/src/dune_rules/foreign_rules.ml b/src/dune_rules/foreign_rules.ml index 360b14b580a4..f461d39c6df4 100644 --- a/src/dune_rules/foreign_rules.ml +++ b/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)) diff --git a/src/dune_rules/recursive_include.ml b/src/dune_rules/recursive_include.ml new file mode 100644 index 000000000000..7695cb8c86de --- /dev/null +++ b/src/dune_rules/recursive_include.ml @@ -0,0 +1,101 @@ +open! Import + +module type Base_term = sig + type t + + val decode : t Dune_lang.Decoder.t +end + +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 type 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 + +module Make (Base_term : Base_term) (Config : Config) = 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 diff --git a/src/dune_rules/recursive_include.mli b/src/dune_rules/recursive_include.mli new file mode 100644 index 000000000000..4421dbcba6a2 --- /dev/null +++ b/src/dune_rules/recursive_include.mli @@ -0,0 +1,54 @@ +(** Encapsulates the situation where you have a configuration language made up + of a sequence of terms (e.g. a list of directories to search for foreign + header files), and want to add a new term to the language (include ) + which parses a sexp list of terms in the same configuration language from + the file at and effectively replaces the (include ...) statement with + the result of parsing the file. Supports chains of recursively included + files, and detects include loops. *) + +open! Import + +(** The type of a term in the configuration language without (include ...) terms *) +module type Base_term = sig + type t + + val decode : t Dune_lang.Decoder.t +end + +module type Config = sig + (** The keyword that will be used to identify an include statement (ie. the + "include" in (include ...)) *) + val include_keyword : string + + (** An expected use case for this module is adding (include ...) statements to + existing configuration languages used in dune fields, and in such cases + we'll want to assert that (include ...) statements are only used beyond a + particular version of dune. An error will be throw during parsing if an + (include ...) statement is encountered in versions of dune that don't + satisfy this predicate. *) + val include_allowed_in_versions : [ `Since of Syntax.Version.t | `All ] + + (** What to do if the included file doesn't contain a sexp *) + val non_sexp_behaviour : [ `User_error | `Parse_as_base_term ] +end + +module Make (Base_term : Base_term) (_ : Config) : sig + (** The type of terms in the configuration language obtained by adding + (include ...) statements to the base language *) + type t + + val of_base : Base_term.t -> t + + val decode : t Dune_lang.Decoder.t + + (** Recursively expands (include ...) terms in the language, producing a list + of terms in the original language (the language without (include ...) + statements). Paths referred to by (include ) are resolved relative + to [dir]. Paths are given as [String_with_vars.t], and the [expand_str] + function is used to resolve them to strings. *) + val expand_include : + t + -> expand_str:(String_with_vars.t -> string Memo.t) + -> dir:Path.Build.t + -> Base_term.t list Memo.t +end