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 <me@emillon.org>
This commit is contained in:
parent
835a44ff1e
commit
4823795fd1
|
@ -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 })
|
||||
])
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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 \
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
"(<file> as <file>) expected"
|
||||
|
|
|
@ -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 ())
|
||||
|
||||
|
|
Loading…
Reference in New Issue