From 4823795fd1a20febd24d70fd18d6b7c974c8207f Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Tue, 31 Jul 2018 09:24:34 +0200 Subject: [PATCH] Use let%map for applicative code This converts easy instances of applicative code. The rewrite rule is generally speaking: ```ocaml e1 >>= pat1 -> e2 >>= pat2 -> e3 >>| pat3 -> r ``` to: ```ocaml let%map pat1 = e1 and pat2 = e2 and pat3 = e3 in r ``` Signed-off-by: Etienne Millon --- src/action.ml | 78 ++++++++++++++++++++++---------------- src/config.ml | 13 +++---- src/dune_project.ml | 55 ++++++++++++++------------- src/inline_tests.ml | 52 ++++++++++++------------- src/installed_dune_file.ml | 7 ++-- src/jbuild.ml | 10 +++-- src/ordered_set_lang.ml | 20 +++++----- src/preprocessing.ml | 25 ++++++------ src/promotion.ml | 9 +++-- src/workspace.ml | 58 ++++++++++++++-------------- 10 files changed, 171 insertions(+), 156 deletions(-) diff --git a/src/action.ml b/src/action.ml index 28c60053..05f75c0b 100644 --- a/src/action.ml +++ b/src/action.ml @@ -28,29 +28,35 @@ struct Sexp.Of_sexp.fix (fun t -> sum [ "run", - (Program.t >>= fun prog -> - repeat string >>| fun args -> + (let%map prog = Program.t + and args = repeat string + in Run (prog, args)) ; "chdir", - (path >>= fun dn -> - t >>| fun t -> + (let%map dn = path + and t = t + in Chdir (dn, t)) ; "setenv", - (string >>= fun k -> - string >>= fun v -> - t >>| fun t -> + (let%map k = string + and v = string + and t = t + in Setenv (k, v, t)) ; "with-stdout-to", - (path >>= fun fn -> - t >>| fun t -> + (let%map fn = path + and t = t + in Redirect (Stdout, fn, t)) ; "with-stderr-to", - (path >>= fun fn -> - t >>| fun t -> + (let%map fn = path + and t = t + in Redirect (Stderr, fn, t)) ; "with-outputs-to", - (path >>= fun fn -> - t >>| fun t -> + (let%map fn = path + and t = t + in Redirect (Outputs, fn, t)) ; "ignore-stdout", (t >>| fun t -> Ignore (Stdout, t)) @@ -61,35 +67,41 @@ struct ; "progn", (repeat t >>| fun l -> Progn l) ; "echo", - (string >>= fun x -> - repeat string >>| fun xs -> + (let%map x = string + and xs = repeat string + in Echo (x :: xs)) ; "cat", (path >>| fun x -> Cat x) ; "copy", - (path >>= fun src -> - path >>| fun dst -> + (let%map src = path + and dst = path + in Copy (src, dst)) ; "copy#", - (path >>= fun src -> - path >>| fun dst -> + (let%map src = path + and dst = path + in Copy_and_add_line_directive (src, dst)) ; "copy-and-add-line-directive", - (path >>= fun src -> - path >>| fun dst -> + (let%map src = path + and dst = path + in Copy_and_add_line_directive (src, dst)) ; "system", (string >>| fun cmd -> System cmd) ; "bash", (string >>| fun cmd -> Bash cmd) ; "write-file", - (path >>= fun fn -> - string >>| fun s -> + (let%map fn = path + and s = string + in Write_file (fn, s)) ; "diff", - (path >>= fun file1 -> - path >>= fun file2 -> - Stanza.file_kind () >>| fun kind -> + (let%map file1 = path + and file2 = path + and kind = Stanza.file_kind () + in let mode = match kind with | Jbuild -> Diff_mode.Text_jbuild @@ -97,9 +109,10 @@ struct in Diff { optional = false; file1; file2; mode }) ; "diff?", - (path >>= fun file1 -> - path >>= fun file2 -> - Stanza.file_kind () >>| fun kind -> + (let%map file1 = path + and file2 = path + and kind = Stanza.file_kind () + in let mode = match kind with | Jbuild -> Diff_mode.Text_jbuild @@ -107,9 +120,10 @@ struct in Diff { optional = true; file1; file2; mode }) ; "cmp", - (Syntax.since Stanza.syntax (1, 0) >>= fun () -> - path >>= fun file1 -> - path >>| fun file2 -> + (let%map () = Syntax.since Stanza.syntax (1, 0) + and file1 = path + and file2 = path + in Diff { optional = false; file1; file2; mode = Binary }) ]) diff --git a/src/config.ml b/src/config.ml index bfe88e2d..94bb43a3 100644 --- a/src/config.ml +++ b/src/config.ml @@ -110,13 +110,12 @@ let default = } let t = - field "display" Display.t ~default:default.display - >>= fun display -> - field "jobs" Concurrency.t ~default:default.concurrency - >>= fun concurrency -> - return { display - ; concurrency - } + let%map display = field "display" Display.t ~default:default.display + and concurrency = field "jobs" Concurrency.t ~default:default.concurrency + in + { display + ; concurrency + } let t = fields t diff --git a/src/dune_project.ml b/src/dune_project.ml index 021336ee..910ffd86 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -320,23 +320,26 @@ let default_name ~dir ~packages = name let name ~dir ~packages = - field_o "name" Name.named_of_sexp >>= function - | Some x -> return x - | None -> return (default_name ~dir ~packages) + let%map name = field_o "name" Name.named_of_sexp in + match name with + | Some x -> x + | None -> default_name ~dir ~packages let parse ~dir ~lang ~packages ~file = fields - (name ~dir ~packages >>= fun name -> - field_o "version" string >>= fun version -> - multi_field "using" - (loc >>= fun loc -> - located string >>= fun name -> - located Syntax.Version.t >>= fun ver -> - (* We don't parse the arguments quite yet as we want to set - the version of extensions before parsing them. *) - capture >>= fun parse_args -> - return (Extension.instantiate ~loc ~parse_args name ver)) - >>= fun extensions -> + (let%map name = name ~dir ~packages + and version = field_o "version" string + and extensions = + multi_field "using" + (let%map loc = loc + and name = located string + and ver = located Syntax.Version.t + and parse_args = capture + in + (* We don't parse the arguments quite yet as we want to set + the version of extensions before parsing them. *) + Extension.instantiate ~loc ~parse_args name ver) + in match String.Map.of_list (List.map extensions ~f:(fun (e : Extension.instance) -> @@ -359,15 +362,14 @@ let parse ~dir ~lang ~packages ~file = ext.parse_args (Sexp.Of_sexp.set_many parsing_context ext.extension.stanzas))) in - return - { kind = Dune - ; name - ; root = get_local_path dir - ; version - ; packages - ; stanza_parser = Sexp.Of_sexp.(set_many parsing_context (sum stanzas)) - ; project_file - }) + { kind = Dune + ; name + ; root = get_local_path dir + ; version + ; packages + ; stanza_parser = Sexp.Of_sexp.(set_many parsing_context (sum stanzas)) + ; project_file + }) let load_dune_project ~dir packages = let file = Path.relative dir filename in @@ -389,9 +391,10 @@ let make_jbuilder_project ~dir packages = let read_name file = load file ~f:(fun _lang -> fields - (field_o "name" string >>= fun name -> - junk_everything >>= fun () -> - return name)) + (let%map name = field_o "name" string + and () = junk_everything + in + name)) let load ~dir ~files = let packages = diff --git a/src/inline_tests.ml b/src/inline_tests.ml index fe528b19..8f3a1e8a 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -34,21 +34,18 @@ module Backend = struct let parse = record - (loc >>= fun loc -> - field "runner_libraries" (list (located string)) ~default:[] - >>= fun runner_libraries -> - Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> - field_o "generate_runner" (located Action.Unexpanded.t) - >>= fun generate_runner -> - field "extends" (list (located string)) ~default:[] - >>= fun extends -> - return - { loc - ; runner_libraries - ; flags - ; generate_runner - ; extends - }) + (let%map loc = loc + and runner_libraries = field "runner_libraries" (list (located string)) ~default:[] + and flags = Ordered_set_lang.Unexpanded.field "flags" + and generate_runner = field_o "generate_runner" (located Action.Unexpanded.t) + and extends = field "extends" (list (located string)) ~default:[] + in + { loc + ; runner_libraries + ; flags + ; generate_runner + ; extends + }) end type t = @@ -137,19 +134,18 @@ include Sub_system.Register_end_point( | true -> loc >>| empty | false -> record - (loc >>= fun loc -> - field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> - Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> - field_o "backend" (located string) >>= fun backend -> - field "libraries" (list (located string)) ~default:[] - >>= fun libraries -> - return - { loc - ; deps - ; flags - ; backend - ; libraries - }) + (let%map loc = loc + and deps = field "deps" (list Dep_conf.t) ~default:[] + and flags = Ordered_set_lang.Unexpanded.field "flags" + and backend = field_o "backend" (located string) + and libraries = field "libraries" (list (located string)) ~default:[] + in + { loc + ; deps + ; flags + ; backend + ; libraries + }) end let gen_rules c ~(info:Info.t) ~backends = diff --git a/src/installed_dune_file.ml b/src/installed_dune_file.ml index c8bfae70..75d4528c 100644 --- a/src/installed_dune_file.ml +++ b/src/installed_dune_file.ml @@ -48,9 +48,10 @@ let of_sexp = [ "dune", (version >>= fun version -> set (Syntax.key Stanza.syntax) version - (get_all >>= fun parsing_context -> - list raw >>| - parse_sub_systems ~parsing_context)) + (let%map parsing_context = get_all + and sub_systems = list raw + in + parse_sub_systems ~parsing_context sub_systems)) ] let load fname = diff --git a/src/jbuild.ml b/src/jbuild.ml index c6496d72..5002c0ad 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -1302,12 +1302,14 @@ module Rule = struct and locks = field "locks" (list String_with_vars.t) ~default:[] and mode = map_validate - (field_b + (let%map fallback = + field_b ~check:(Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"(mode fallback)") - "fallback" >>= fun fallback -> - field_o "mode" Mode.t >>= fun mode -> - return (fallback, mode)) + "fallback" + and mode = field_o "mode" Mode.t + in + (fallback, mode)) ~f:(function | true, Some _ -> Error "Cannot use both (fallback) and (mode ...) at the \ diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index 4881b025..6a3fee96 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -91,10 +91,11 @@ end let t = let open Stanza.Of_sexp in - get_all >>= fun context -> - located (Parse.without_include - ~elt:(plain_string (fun ~loc s -> Ast.Element (loc, s)))) - >>| fun (loc, ast) -> + let%map context = get_all + and (loc, ast) = + located (Parse.without_include + ~elt:(plain_string (fun ~loc s -> Ast.Element (loc, s)))) + in { ast; loc = Some loc; context } let is_standard t = @@ -237,11 +238,12 @@ module Unexpanded = struct type t = ast generic let t : t Sexp.Of_sexp.t = let open Stanza.Of_sexp in - get_all >>= fun context -> - located ( - Parse.with_include - ~elt:(String_with_vars.t >>| fun s -> Ast.Element s)) - >>| fun (loc, ast) -> + let%map context = get_all + and (loc, ast) = + located ( + Parse.with_include + ~elt:(String_with_vars.t >>| fun s -> Ast.Element s)) + in { ast ; loc = Some loc ; context diff --git a/src/preprocessing.ml b/src/preprocessing.ml index c8db4ebd..0f567024 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -44,19 +44,18 @@ module Driver = struct let parse = record - (loc >>= fun loc -> - Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> - Ordered_set_lang.Unexpanded.field "lint_flags" >>= fun lint_flags -> - field "main" string >>= fun main -> - field "replaces" (list (located string)) ~default:[] - >>= fun replaces -> - return - { loc - ; flags - ; lint_flags - ; main - ; replaces - }) + (let%map loc = loc + and flags = Ordered_set_lang.Unexpanded.field "flags" + and lint_flags = Ordered_set_lang.Unexpanded.field "lint_flags" + and main = field "main" string + and replaces = field "replaces" (list (located string)) ~default:[] + in + { loc + ; flags + ; lint_flags + ; main + ; replaces + }) end (* The [lib] field is lazy so that we don't need to fill it for diff --git a/src/promotion.ml b/src/promotion.ml index 5873b2a2..00c2255c 100644 --- a/src/promotion.ml +++ b/src/promotion.ml @@ -12,10 +12,11 @@ module File = struct peek_exn >>= function | List (_, [_; Atom (_, A "as"); _]) -> enter - (Path.t >>= fun src -> - junk >>= fun () -> - Path.t >>= fun dst -> - return { src; dst }) + (let%map src = Path.t + and () = junk + and dst = Path.t + in + { src; dst }) | sexp -> Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp) "( as ) expected" diff --git a/src/workspace.ml b/src/workspace.ml index ad1e5e4a..cfbff66e 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -54,18 +54,16 @@ module Context = struct } let t ~profile = - env_field >>= fun env -> - field "targets" (list Target.t) ~default:[Target.Native] - >>= fun targets -> - field "profile" string ~default:profile - >>= fun profile -> - loc >>= fun loc -> - return - { targets - ; profile - ; loc - ; env - } + let%map env = env_field + and targets = field "targets" (list Target.t) ~default:[Target.Native] + and profile = field "profile" string ~default:profile + and loc = loc + in + { targets + ; profile + ; loc + ; env + } end module Opam = struct @@ -79,25 +77,26 @@ module Context = struct let t ~profile ~x = Common.t ~profile >>= fun base -> - field "switch" string >>= fun switch -> - field "name" Name.t ~default:switch >>= fun name -> - field_o "root" string >>= fun root -> - field_b "merlin" >>= fun merlin -> + field "switch" string >>= fun switch -> + let%map name = field "name" Name.t ~default:switch + and root = field_o "root" string + and merlin = field_b "merlin" + in let base = { base with targets = Target.add base.targets x } in - return { base - ; switch - ; name - ; root - ; merlin - } + { base + ; switch + ; name + ; root + ; merlin + } end module Default = struct type t = Common.t let t ~profile ~x = - Common.t ~profile >>= fun t -> - return { t with targets = Target.add t.targets x } + Common.t ~profile >>| fun t -> + { t with targets = Target.add t.targets x } end type t = Default of Default.t | Opam of Opam.t @@ -165,7 +164,7 @@ let t ?x ?profile:cmdline_profile () = >>= fun profile -> let profile = Option.value cmdline_profile ~default:profile in multi_field "context" (Context.t ~profile ~x) - >>= fun contexts -> + >>| fun contexts -> let defined_names = ref String.Set.empty in let { merlin_context; contexts; env } = let init = @@ -205,11 +204,10 @@ let t ?x ?profile:cmdline_profile () = else None in - return - { merlin_context - ; contexts = List.rev contexts - ; env - } + { merlin_context + ; contexts = List.rev contexts + ; env + } let t ?x ?profile () = fields (t ?x ?profile ())