From f121a1546e87c092581f7c5989c9b2541a0e52f0 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 5 Jul 2018 23:33:51 +0700 Subject: [PATCH] Generalize named bindings to Jbuild.Named.t Signed-off-by: Rudi Grinberg --- src/gen_rules.ml | 6 +-- src/jbuild.ml | 103 ++++++++++++++++++++++-------------------- src/jbuild.mli | 21 +++++---- src/super_context.ml | 2 +- src/super_context.mli | 4 +- 5 files changed, 71 insertions(+), 65 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index bbf7d990..b853de4e 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -187,7 +187,7 @@ module Gen(P : Install_rules.Params) = struct in SC.add_rule_get_targets sctx ~mode:rule.mode ~loc:rule.loc ~locks:(interpret_locks ~dir ~scope rule.locks) - (SC.Deps.interpret_bindings sctx ~scope ~dir rule.deps + (SC.Deps.interpret_named sctx ~scope ~dir rule.deps >>> SC.Action.run sctx @@ -929,7 +929,7 @@ module Gen(P : Install_rules.Params) = struct let module S = Sexp.To_sexp in Sexp.List [ Sexp.unsafe_atom_of_string "user-alias" - ; Jbuild.Dep_conf.sexp_of_bindings alias_conf.deps + ; Jbuild.Named.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps ; S.option Action.Unexpanded.sexp_of_t (Option.map alias_conf.action ~f:snd) ] @@ -939,7 +939,7 @@ module Gen(P : Install_rules.Params) = struct ~name:alias_conf.name ~stamp ~locks:(interpret_locks ~dir ~scope alias_conf.locks) - (SC.Deps.interpret_bindings sctx ~scope ~dir alias_conf.deps + (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps >>> match alias_conf.action with | None -> Build.progn [] diff --git a/src/jbuild.ml b/src/jbuild.ml index 0ed88f39..ddaaf303 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -232,6 +232,52 @@ module Pps_and_flags = struct Dune_syntax.t end +module Named = struct + type 'a t = + { named: (Loc.t * 'a list) String.Map.t + ; unnamed : 'a list + } + + let empty = + { named = String.Map.empty + ; unnamed = [] + } + + let t elem = + let binding = + peek_exn >>= function + | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> + begin + string >>= fun name -> + peek >>= function + | None -> of_sexp_errorf loc "Naked binding %s" s + | Some _ -> + elem >>| fun elem -> + Left (name, (loc, elem)) + end + | _ -> + elem >>| fun elem -> Right elem + in + list binding >>| (fun bindings -> + let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in + { unnamed = List.flatten unnamed + ; named = + match String.Map.of_list named with + | Ok x -> x + | Error (name, (l1, _), (l2, _)) -> + of_sexp_errorf l1 "Variable %s is already defined in %s" + name (Loc.to_file_colon_line l2) + }) + + let sexp_of_t sexp_of_a { unnamed; named } = + let unnamed = List.map ~f:sexp_of_a unnamed in + let named = + String.Map.foldi ~init:[] named ~f:(fun n (_, d) acc -> + Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_a d) @ acc) + in + Sexp.List (unnamed @ named) +end + module Dep_conf = struct type t = | File of String_with_vars.t @@ -242,16 +288,6 @@ module Dep_conf = struct | Package of String_with_vars.t | Universe - type bindings = - { named : (Loc.t * t list) String.Map.t - ; unnamed : t list - } - - let empty_bindings = - { named = String.Map.empty - ; unnamed = [] - } - let dep_cons = let sw = String_with_vars.t in [ "file" , (sw >>| fun x -> File x) @@ -285,30 +321,7 @@ module Dep_conf = struct :: List.map dep_cons ~f:(fun (n, d) -> (n, d >>| List.singleton)) |> sum) in - let binding = - peek_exn >>= function - | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> - begin - string >>= fun name -> - peek >>= function - | None -> of_sexp_errorf loc "Naked binding %s" s - | Some _ -> dep - >>| fun deps -> - Left (name, (loc, deps)) - end - | _ -> - dep >>| fun dep -> Right dep - in - list binding >>| (fun bindings -> - let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in - { unnamed = List.flatten unnamed - ; named = - match String.Map.of_list named with - | Ok x -> x - | Error (name, (l1, _), (l2, _)) -> - of_sexp_errorf l1 "Variable %s is already defined in %s" - name (Loc.to_file_colon_line l2) - }) + Named.t dep open Sexp let sexp_of_t = function @@ -330,14 +343,6 @@ module Dep_conf = struct String_with_vars.sexp_of_t t] | Universe -> Sexp.unsafe_atom_of_string "universe" - - let sexp_of_bindings { unnamed; named } = - let unnamed = List.map ~f:sexp_of_t unnamed in - let named = - String.Map.foldi ~init:[] named ~f:(fun n (_, d) acc -> - Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_t d) @ acc) - in - List (unnamed @ named) end module Preprocess = struct @@ -1123,7 +1128,7 @@ module Rule = struct type t = { targets : Targets.t - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -1165,7 +1170,7 @@ module Rule = struct let short_form = located Action.Unexpanded.t >>| fun (loc, action) -> { targets = Infer - ; deps = Dep_conf.empty_bindings + ; deps = Named.empty ; action = (loc, action) ; mode = Standard ; locks = [] @@ -1178,7 +1183,7 @@ module Rule = struct >>= fun action -> field "targets" (list file_in_current_dir) >>= fun targets -> - field "deps" (Dep_conf.bindings) ~default:Dep_conf.empty_bindings + field "deps" Dep_conf.bindings ~default:Named.empty >>= fun deps -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> map_validate @@ -1284,7 +1289,7 @@ module Rule = struct let src = name ^ ".mll" in let dst = name ^ ".ml" in { targets = Static [dst] - ; deps = { Dep_conf.empty_bindings with + ; deps = { Named.empty with unnamed = [File (S.virt_text __POS__ src)] } ; action = @@ -1308,7 +1313,7 @@ module Rule = struct let src = name ^ ".mly" in { targets = Static [name ^ ".ml"; name ^ ".mli"] ; deps = - { Dep_conf.empty_bindings with + { Named.empty with unnamed = [File (S.virt_text __POS__ src)] } ; action = @@ -1378,7 +1383,7 @@ end module Alias_conf = struct type t = { name : string - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option @@ -1397,7 +1402,7 @@ module Alias_conf = struct field_o "package" Pkg.t >>= fun package -> field_o "action" (located Action.Unexpanded.t) >>= fun action -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> - field "deps" Dep_conf.bindings ~default:Dep_conf.empty_bindings + field "deps" Dep_conf.bindings ~default:Named.empty >>= fun deps -> return { name diff --git a/src/jbuild.mli b/src/jbuild.mli index 6afc35a9..50b394e8 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -81,6 +81,15 @@ module Lib_deps : sig val of_pps : Pp.t list -> t end +module Named : sig + type 'a t = + { named : (Loc.t * 'a list) String.Map.t + ; unnamed : 'a list + } + + val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t +end + module Dep_conf : sig type t = | File of String_with_vars.t @@ -91,16 +100,8 @@ module Dep_conf : sig | Package of String_with_vars.t | Universe - type bindings = - { named: (Loc.t * t list) String.Map.t - ; unnamed : t list - } - - val bindings : bindings Sexp.Of_sexp.t - val t : t Sexp.Of_sexp.t val sexp_of_t : t -> Sexp.t - val sexp_of_bindings : bindings -> Sexp.t end module Buildable : sig @@ -292,7 +293,7 @@ module Rule : sig type t = { targets : Targets.t - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -315,7 +316,7 @@ end module Alias_conf : sig type t = { name : string - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option diff --git a/src/super_context.ml b/src/super_context.ml index c2561b18..7393410f 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -527,7 +527,7 @@ module Deps = struct |> Build.all >>^ List.concat - let interpret_bindings t ~scope ~dir { unnamed; named } = + let interpret_named t ~scope ~dir { Named.unnamed; named } = String.Map.fold ~init:unnamed named ~f:(fun (_, ds) acc -> List.rev_append ds acc) |> List.map ~f:(dep t ~scope ~dir) diff --git a/src/super_context.mli b/src/super_context.mli index 8d668d18..eb86dd28 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -220,11 +220,11 @@ module Deps : sig -> Dep_conf.t list -> (unit, Path.t list) Build.t - val interpret_bindings + val interpret_named : t -> scope:Scope.t -> dir:Path.t - -> Dep_conf.bindings + -> Dep_conf.t Named.t -> (unit, Path.t list) Build.t end