diff --git a/src/action.ml b/src/action.ml index 71d9b1bc..f722bec1 100644 --- a/src/action.ml +++ b/src/action.ml @@ -130,59 +130,83 @@ struct Diff { optional = false; file1; file2; mode = Binary }) ]) - let rec dgen = - let path = Path.dgen and string = String.dgen in - function - | Run (a, xs) -> Dsexp.List (Dsexp.unsafe_atom_of_string "run" - :: Program.dgen a :: List.map xs ~f:string) - | Chdir (a, r) -> List [Dsexp.unsafe_atom_of_string "chdir" ; - path a ; dgen r] - | Setenv (k, v, r) -> List [Dsexp.unsafe_atom_of_string "setenv" ; - string k ; string v ; dgen r] - | Redirect (outputs, fn, r) -> - List [ Dsexp.atom (sprintf "with-%s-to" (Outputs.to_string outputs)) - ; path fn - ; dgen r - ] - | Ignore (outputs, r) -> - List [ Dsexp.atom (sprintf "ignore-%s" (Outputs.to_string outputs)) - ; dgen r - ] - | Progn l -> List (Dsexp.unsafe_atom_of_string "progn" - :: List.map l ~f:dgen) - | Echo xs -> - List (Dsexp.unsafe_atom_of_string "echo" :: List.map xs ~f:string) - | Cat x -> List [Dsexp.unsafe_atom_of_string "cat"; path x] - | Copy (x, y) -> - List [Dsexp.unsafe_atom_of_string "copy"; path x; path y] - | Symlink (x, y) -> - List [Dsexp.unsafe_atom_of_string "symlink"; path x; path y] - | Copy_and_add_line_directive (x, y) -> - List [Dsexp.unsafe_atom_of_string "copy#"; path x; path y] - | System x -> List [Dsexp.unsafe_atom_of_string "system"; string x] - | Bash x -> List [Dsexp.unsafe_atom_of_string "bash"; string x] - | Write_file (x, y) -> List [Dsexp.unsafe_atom_of_string "write-file"; - path x; string y] - | Rename (x, y) -> List [Dsexp.unsafe_atom_of_string "rename"; - path x; path y] - | Remove_tree x -> List [Dsexp.unsafe_atom_of_string "remove-tree"; path x] - | Mkdir x -> List [Dsexp.unsafe_atom_of_string "mkdir"; path x] - | Digest_files paths -> List [Dsexp.unsafe_atom_of_string "digest-files"; - List (List.map paths ~f:path)] - | Diff { optional; file1; file2; mode = Binary} -> - assert (not optional); - List [Dsexp.unsafe_atom_of_string "cmp"; path file1; path file2] - | Diff { optional = false; file1; file2; mode = _ } -> - List [Dsexp.unsafe_atom_of_string "diff"; path file1; path file2] - | Diff { optional = true; file1; file2; mode = _ } -> - List [Dsexp.unsafe_atom_of_string "diff?"; path file1; path file2] - | Merge_files_into (srcs, extras, target) -> - List - [ Dsexp.unsafe_atom_of_string "merge-files-into" - ; List (List.map ~f:path srcs) - ; List (List.map ~f:string extras) - ; path target - ] + module Make_gen (P : sig + type sexp + val atom : string -> sexp + val list : sexp list -> sexp + val path : Path.t -> sexp + val string : String.t -> sexp + val program : Program.t -> sexp + end) = struct + open P + let rec gen = + function + | Run (a, xs) -> + list (atom "run" :: program a :: List.map xs ~f:string) + | Chdir (a, r) -> list [atom "chdir" ; path a ; gen r] + | Setenv (k, v, r) -> list [atom "setenv" ; string k ; string v ; gen r] + | Redirect (outputs, fn, r) -> + list [ atom (sprintf "with-%s-to" (Outputs.to_string outputs)) + ; path fn + ; gen r + ] + | Ignore (outputs, r) -> + list [ atom (sprintf "ignore-%s" (Outputs.to_string outputs)) + ; gen r + ] + | Progn l -> list (atom "progn" :: List.map l ~f:gen) + | Echo xs -> + list (atom "echo" :: List.map xs ~f:string) + | Cat x -> list [atom "cat"; path x] + | Copy (x, y) -> + list [atom "copy"; path x; path y] + | Symlink (x, y) -> + list [atom "symlink"; path x; path y] + | Copy_and_add_line_directive (x, y) -> + list [atom "copy#"; path x; path y] + | System x -> list [atom "system"; string x] + | Bash x -> list [atom "bash"; string x] + | Write_file (x, y) -> list [atom "write-file"; path x; string y] + | Rename (x, y) -> list [atom "rename"; path x; path y] + | Remove_tree x -> list [atom "remove-tree"; path x] + | Mkdir x -> list [atom "mkdir"; path x] + | Digest_files paths -> list [atom "digest-files"; + list (List.map paths ~f:path)] + | Diff { optional; file1; file2; mode = Binary} -> + assert (not optional); + list [atom "cmp"; path file1; path file2] + | Diff { optional = false; file1; file2; mode = _ } -> + list [atom "diff"; path file1; path file2] + | Diff { optional = true; file1; file2; mode = _ } -> + list [atom "diff?"; path file1; path file2] + | Merge_files_into (srcs, extras, target) -> + list + [ atom "merge-files-into" + ; list (List.map ~f:path srcs) + ; list (List.map ~f:string extras) + ; path target + ] + end + + module Dgen = Make_gen(struct + type sexp = Dsexp.t + let atom = Dsexp.unsafe_atom_of_string + let list s = Dsexp.List s + let program = Program.dgen + let string = String.dgen + let path = Path.dgen + end) + let dgen = Dgen.gen + + module Sexpgen = Make_gen(struct + type sexp = Sexp.t + let atom a = Sexp.Atom a + let list a = Sexp.List a + let program s = Dsexp.sexp_of_t (Program.dgen s) + let string s = Dsexp.sexp_of_t (String.dgen s) + let path s = Dsexp.sexp_of_t (Path.dgen s) + end) + let sexp_of_t = Sexpgen.gen let run prog args = Run (prog, args) let chdir path t = Chdir (path, t) diff --git a/src/action.mli b/src/action.mli index a0e68541..75fdb109 100644 --- a/src/action.mli +++ b/src/action.mli @@ -95,6 +95,8 @@ module Unexpanded : sig -> map_exe:(Path.t -> Path.t) -> f:(Value.t list option String_with_vars.expander) -> Partial.t + + val sexp_of_t : t Sexp.To_sexp.t end (** Infer dependencies and targets. diff --git a/src/build_system.ml b/src/build_system.ml index 31f1f3e1..7ed0d465 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -1621,7 +1621,7 @@ module Alias = struct let add_action build_system t ~context ~loc ?(locks=[]) ~stamp action = let def = get_alias_def build_system t in - def.actions <- { stamp = Digest.string (Dsexp.to_string ~syntax:Dune stamp) + def.actions <- { stamp = Digest.string (Sexp.to_string stamp) ; action ; locks ; context diff --git a/src/build_system.mli b/src/build_system.mli index 9bd01cc4..3298b92f 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -174,7 +174,7 @@ module Alias : sig -> context:Context.t -> loc:Loc.t option -> ?locks:Path.t list - -> stamp:Dsexp.t + -> stamp:Sexp.t -> (unit, Action.t) Build.t -> unit end with type build_system := t diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 525e9d24..5d2a6d45 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -261,8 +261,8 @@ include Sub_system.Register_end_point( SC.add_alias_action sctx ~loc:(Some info.loc) (Build_system.Alias.runtest ~dir) - ~stamp:(List [ Dsexp.unsafe_atom_of_string "ppx-runner" - ; Quoted_string name + ~stamp:(List [ Sexp.Atom "ppx-runner" + ; Atom name ]) (let module A = Action in let exe = Path.relative inline_test_dir (name ^ ".exe") in diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 40bf7ad4..5c9e1b29 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -463,9 +463,9 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = let alias = Build_system.Alias.lint ~dir in let add_alias fn build = SC.add_alias_action sctx alias build - ~stamp:(List [ Dsexp.unsafe_atom_of_string "lint" - ; Dsexp.To_sexp.(option string) lib_name - ; Path_dsexp.dgen fn + ~stamp:(List [ Sexp.Atom "lint" + ; Sexp.To_sexp.(option string) lib_name + ; Path.sexp_of_t fn ]) in let lint = diff --git a/src/simple_rules.ml b/src/simple_rules.ml index a329132b..0c063268 100644 --- a/src/simple_rules.ml +++ b/src/simple_rules.ml @@ -90,10 +90,10 @@ let alias sctx ~dir ~scope (alias_conf : Alias_conf.t) = Blang.eval_bool blang ~dir ~f in let stamp = - Dsexp.List - [ Dsexp.unsafe_atom_of_string "user-alias" - ; Dune_file.Bindings.dgen Dune_file.Dep_conf.dgen alias_conf.deps - ; Dsexp.To_sexp.option Action.Unexpanded.dgen + Sexp.List + [ Sexp.Atom "user-alias" + ; Dune_file.Bindings.sexp_of_t Dune_file.Dep_conf.sexp_of_t alias_conf.deps + ; Sexp.To_sexp.option Action.Unexpanded.sexp_of_t (Option.map alias_conf.action ~f:snd) ] in diff --git a/src/super_context.mli b/src/super_context.mli index 6dbc1429..be99ede3 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -151,7 +151,7 @@ val add_alias_action -> Build_system.Alias.t -> loc:Loc.t option -> ?locks:Path.t list - -> stamp:Dsexp.t + -> stamp:Sexp.t -> (unit, Action.t) Build.t -> unit