matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Etienne Millon 2018-07-31 09:24:34 +02:00
parent 835a44ff1e
commit 4823795fd1
10 changed files with 171 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
src/action.ml
View File

@ -28,29 +28,35 @@ struct
Sexp.Of_sexp.fix (fun t -> Sexp.Of_sexp.fix (fun t ->
sum sum
[ "run", [ "run",
(Program.t >>= fun prog -> (let%map prog = Program.t
repeat string >>| fun args -> and args = repeat string
in
Run (prog, args)) Run (prog, args))
; "chdir", ; "chdir",
(path >>= fun dn -> (let%map dn = path
t >>| fun t -> and t = t
in
Chdir (dn, t)) Chdir (dn, t))
; "setenv", ; "setenv",
(string >>= fun k -> (let%map k = string
string >>= fun v -> and v = string
t >>| fun t -> and t = t
in
Setenv (k, v, t)) Setenv (k, v, t))
; "with-stdout-to", ; "with-stdout-to",
(path >>= fun fn -> (let%map fn = path
t >>| fun t -> and t = t
in
Redirect (Stdout, fn, t)) Redirect (Stdout, fn, t))
; "with-stderr-to", ; "with-stderr-to",
(path >>= fun fn -> (let%map fn = path
t >>| fun t -> and t = t
in
Redirect (Stderr, fn, t)) Redirect (Stderr, fn, t))
; "with-outputs-to", ; "with-outputs-to",
(path >>= fun fn -> (let%map fn = path
t >>| fun t -> and t = t
in
Redirect (Outputs, fn, t)) Redirect (Outputs, fn, t))
; "ignore-stdout", ; "ignore-stdout",
(t >>| fun t -> Ignore (Stdout, t)) (t >>| fun t -> Ignore (Stdout, t))
@ -61,35 +67,41 @@ struct
; "progn", ; "progn",
(repeat t >>| fun l -> Progn l) (repeat t >>| fun l -> Progn l)
; "echo", ; "echo",
(string >>= fun x -> (let%map x = string
repeat string >>| fun xs -> and xs = repeat string
in
Echo (x :: xs)) Echo (x :: xs))
; "cat", ; "cat",
(path >>| fun x -> Cat x) (path >>| fun x -> Cat x)
; "copy", ; "copy",
(path >>= fun src -> (let%map src = path
path >>| fun dst -> and dst = path
in
Copy (src, dst)) Copy (src, dst))
; "copy#", ; "copy#",
(path >>= fun src -> (let%map src = path
path >>| fun dst -> and dst = path
in
Copy_and_add_line_directive (src, dst)) Copy_and_add_line_directive (src, dst))
; "copy-and-add-line-directive", ; "copy-and-add-line-directive",
(path >>= fun src -> (let%map src = path
path >>| fun dst -> and dst = path
in
Copy_and_add_line_directive (src, dst)) Copy_and_add_line_directive (src, dst))
; "system", ; "system",
(string >>| fun cmd -> System cmd) (string >>| fun cmd -> System cmd)
; "bash", ; "bash",
(string >>| fun cmd -> Bash cmd) (string >>| fun cmd -> Bash cmd)
; "write-file", ; "write-file",
(path >>= fun fn -> (let%map fn = path
string >>| fun s -> and s = string
in
Write_file (fn, s)) Write_file (fn, s))
; "diff", ; "diff",
(path >>= fun file1 -> (let%map file1 = path
path >>= fun file2 -> and file2 = path
Stanza.file_kind () >>| fun kind -> and kind = Stanza.file_kind ()
in
let mode = let mode =
match kind with match kind with
| Jbuild -> Diff_mode.Text_jbuild | Jbuild -> Diff_mode.Text_jbuild
@ -97,9 +109,10 @@ struct
in in
Diff { optional = false; file1; file2; mode }) Diff { optional = false; file1; file2; mode })
; "diff?", ; "diff?",
(path >>= fun file1 -> (let%map file1 = path
path >>= fun file2 -> and file2 = path
Stanza.file_kind () >>| fun kind -> and kind = Stanza.file_kind ()
in
let mode = let mode =
match kind with match kind with
| Jbuild -> Diff_mode.Text_jbuild | Jbuild -> Diff_mode.Text_jbuild
@ -107,9 +120,10 @@ struct
in in
Diff { optional = true; file1; file2; mode }) Diff { optional = true; file1; file2; mode })
; "cmp", ; "cmp",
(Syntax.since Stanza.syntax (1, 0) >>= fun () -> (let%map () = Syntax.since Stanza.syntax (1, 0)
path >>= fun file1 -> and file1 = path
path >>| fun file2 -> and file2 = path
in
Diff { optional = false; file1; file2; mode = Binary }) Diff { optional = false; file1; file2; mode = Binary })
]) ])

13
src/config.ml
View File

@ -110,13 +110,12 @@ let default =
} }
let t = let t =
field "display" Display.t ~default:default.display let%map display = field "display" Display.t ~default:default.display
>>= fun display -> and concurrency = field "jobs" Concurrency.t ~default:default.concurrency
field "jobs" Concurrency.t ~default:default.concurrency in
>>= fun concurrency -> { display
return { display ; concurrency
; concurrency }
}
let t = fields t let t = fields t

55
src/dune_project.ml
View File

@ -320,23 +320,26 @@ let default_name ~dir ~packages =
name name
let name ~dir ~packages = let name ~dir ~packages =
field_o "name" Name.named_of_sexp >>= function let%map name = field_o "name" Name.named_of_sexp in
| Some x -> return x match name with
| None -> return (default_name ~dir ~packages) | Some x -> x
| None -> default_name ~dir ~packages
let parse ~dir ~lang ~packages ~file = let parse ~dir ~lang ~packages ~file =
fields fields
(name ~dir ~packages >>= fun name -> (let%map name = name ~dir ~packages
field_o "version" string >>= fun version -> and version = field_o "version" string
multi_field "using" and extensions =
(loc >>= fun loc -> multi_field "using"
located string >>= fun name -> (let%map loc = loc
located Syntax.Version.t >>= fun ver -> and name = located string
(* We don't parse the arguments quite yet as we want to set and ver = located Syntax.Version.t
the version of extensions before parsing them. *) and parse_args = capture
capture >>= fun parse_args -> in
return (Extension.instantiate ~loc ~parse_args name ver)) (* We don't parse the arguments quite yet as we want to set
>>= fun extensions -> the version of extensions before parsing them. *)
Extension.instantiate ~loc ~parse_args name ver)
in
match match
String.Map.of_list String.Map.of_list
(List.map extensions ~f:(fun (e : Extension.instance) -> (List.map extensions ~f:(fun (e : Extension.instance) ->
@ -359,15 +362,14 @@ let parse ~dir ~lang ~packages ~file =
ext.parse_args ext.parse_args
(Sexp.Of_sexp.set_many parsing_context ext.extension.stanzas))) (Sexp.Of_sexp.set_many parsing_context ext.extension.stanzas)))
in in
return { kind = Dune
{ kind = Dune ; name
; name ; root = get_local_path dir
; root = get_local_path dir ; version
; version ; packages
; packages ; stanza_parser = Sexp.Of_sexp.(set_many parsing_context (sum stanzas))
; stanza_parser = Sexp.Of_sexp.(set_many parsing_context (sum stanzas)) ; project_file
; project_file })
})
let load_dune_project ~dir packages = let load_dune_project ~dir packages =
let file = Path.relative dir filename in let file = Path.relative dir filename in
@ -389,9 +391,10 @@ let make_jbuilder_project ~dir packages =
let read_name file = let read_name file =
load file ~f:(fun _lang -> load file ~f:(fun _lang ->
fields fields
(field_o "name" string >>= fun name -> (let%map name = field_o "name" string
junk_everything >>= fun () -> and () = junk_everything
return name)) in
name))
let load ~dir ~files = let load ~dir ~files =
let packages = let packages =

52
src/inline_tests.ml
View File

@ -34,21 +34,18 @@ module Backend = struct
let parse = let parse =
record record
(loc >>= fun loc -> (let%map loc = loc
field "runner_libraries" (list (located string)) ~default:[] and runner_libraries = field "runner_libraries" (list (located string)) ~default:[]
>>= fun runner_libraries -> and flags = Ordered_set_lang.Unexpanded.field "flags"
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> and generate_runner = field_o "generate_runner" (located Action.Unexpanded.t)
field_o "generate_runner" (located Action.Unexpanded.t) and extends = field "extends" (list (located string)) ~default:[]
>>= fun generate_runner -> in
field "extends" (list (located string)) ~default:[] { loc
>>= fun extends -> ; runner_libraries
return ; flags
{ loc ; generate_runner
; runner_libraries ; extends
; flags })
; generate_runner
; extends
})
end end
type t = type t =
@ -137,19 +134,18 @@ include Sub_system.Register_end_point(
| true -> loc >>| empty | true -> loc >>| empty
| false -> | false ->
record record
(loc >>= fun loc -> (let%map loc = loc
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> and deps = field "deps" (list Dep_conf.t) ~default:[]
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> and flags = Ordered_set_lang.Unexpanded.field "flags"
field_o "backend" (located string) >>= fun backend -> and backend = field_o "backend" (located string)
field "libraries" (list (located string)) ~default:[] and libraries = field "libraries" (list (located string)) ~default:[]
>>= fun libraries -> in
return { loc
{ loc ; deps
; deps ; flags
; flags ; backend
; backend ; libraries
; libraries })
})
end end
let gen_rules c ~(info:Info.t) ~backends = let gen_rules c ~(info:Info.t) ~backends =

7
src/installed_dune_file.ml
View File

@ -48,9 +48,10 @@ let of_sexp =
[ "dune", [ "dune",
(version >>= fun version -> (version >>= fun version ->
set (Syntax.key Stanza.syntax) version set (Syntax.key Stanza.syntax) version
(get_all >>= fun parsing_context -> (let%map parsing_context = get_all
list raw >>| and sub_systems = list raw
parse_sub_systems ~parsing_context)) in
parse_sub_systems ~parsing_context sub_systems))
] ]
let load fname = let load fname =

10
src/jbuild.ml
View File

@ -1302,12 +1302,14 @@ module Rule = struct
and locks = field "locks" (list String_with_vars.t) ~default:[] and locks = field "locks" (list String_with_vars.t) ~default:[]
and mode = and mode =
map_validate map_validate
(field_b (let%map fallback =
field_b
~check:(Syntax.renamed_in Stanza.syntax (1, 0) ~check:(Syntax.renamed_in Stanza.syntax (1, 0)
~to_:"(mode fallback)") ~to_:"(mode fallback)")
"fallback" >>= fun fallback -> "fallback"
field_o "mode" Mode.t >>= fun mode -> and mode = field_o "mode" Mode.t
return (fallback, mode)) in
(fallback, mode))
~f:(function ~f:(function
| true, Some _ -> | true, Some _ ->
Error "Cannot use both (fallback) and (mode ...) at the \ Error "Cannot use both (fallback) and (mode ...) at the \

20
src/ordered_set_lang.ml
View File

@ -91,10 +91,11 @@ end
let t = let t =
let open Stanza.Of_sexp in let open Stanza.Of_sexp in
get_all >>= fun context -> let%map context = get_all
located (Parse.without_include and (loc, ast) =
~elt:(plain_string (fun ~loc s -> Ast.Element (loc, s)))) located (Parse.without_include
>>| fun (loc, ast) -> ~elt:(plain_string (fun ~loc s -> Ast.Element (loc, s))))
in
{ ast; loc = Some loc; context } { ast; loc = Some loc; context }
let is_standard t = let is_standard t =
@ -237,11 +238,12 @@ module Unexpanded = struct
type t = ast generic type t = ast generic
let t : t Sexp.Of_sexp.t = let t : t Sexp.Of_sexp.t =
let open Stanza.Of_sexp in let open Stanza.Of_sexp in
get_all >>= fun context -> let%map context = get_all
located ( and (loc, ast) =
Parse.with_include located (
~elt:(String_with_vars.t >>| fun s -> Ast.Element s)) Parse.with_include
>>| fun (loc, ast) -> ~elt:(String_with_vars.t >>| fun s -> Ast.Element s))
in
{ ast { ast
; loc = Some loc ; loc = Some loc
; context ; context

25
src/preprocessing.ml
View File

@ -44,19 +44,18 @@ module Driver = struct
let parse = let parse =
record record
(loc >>= fun loc -> (let%map loc = loc
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> and flags = Ordered_set_lang.Unexpanded.field "flags"
Ordered_set_lang.Unexpanded.field "lint_flags" >>= fun lint_flags -> and lint_flags = Ordered_set_lang.Unexpanded.field "lint_flags"
field "main" string >>= fun main -> and main = field "main" string
field "replaces" (list (located string)) ~default:[] and replaces = field "replaces" (list (located string)) ~default:[]
>>= fun replaces -> in
return { loc
{ loc ; flags
; flags ; lint_flags
; lint_flags ; main
; main ; replaces
; replaces })
})
end end
(* The [lib] field is lazy so that we don't need to fill it for (* The [lib] field is lazy so that we don't need to fill it for

9
src/promotion.ml
View File

@ -12,10 +12,11 @@ module File = struct
peek_exn >>= function peek_exn >>= function
| List (_, [_; Atom (_, A "as"); _]) -> | List (_, [_; Atom (_, A "as"); _]) ->
enter enter
(Path.t >>= fun src -> (let%map src = Path.t
junk >>= fun () -> and () = junk
Path.t >>= fun dst -> and dst = Path.t
return { src; dst }) in
{ src; dst })
| sexp -> | sexp ->
Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp) Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp)
"(<file> as <file>) expected" "(<file> as <file>) expected"

58
src/workspace.ml
View File

@ -54,18 +54,16 @@ module Context = struct
} }
let t ~profile = let t ~profile =
env_field >>= fun env -> let%map env = env_field
field "targets" (list Target.t) ~default:[Target.Native] and targets = field "targets" (list Target.t) ~default:[Target.Native]
>>= fun targets -> and profile = field "profile" string ~default:profile
field "profile" string ~default:profile and loc = loc
>>= fun profile -> in
loc >>= fun loc -> { targets
return ; profile
{ targets ; loc
; profile ; env
; loc }
; env
}
end end
module Opam = struct module Opam = struct
@ -79,25 +77,26 @@ module Context = struct
let t ~profile ~x = let t ~profile ~x =
Common.t ~profile >>= fun base -> Common.t ~profile >>= fun base ->
field "switch" string >>= fun switch -> field "switch" string >>= fun switch ->
field "name" Name.t ~default:switch >>= fun name -> let%map name = field "name" Name.t ~default:switch
field_o "root" string >>= fun root -> and root = field_o "root" string
field_b "merlin" >>= fun merlin -> and merlin = field_b "merlin"
in
let base = { base with targets = Target.add base.targets x } in let base = { base with targets = Target.add base.targets x } in
return { base { base
; switch ; switch
; name ; name
; root ; root
; merlin ; merlin
} }
end end
module Default = struct module Default = struct
type t = Common.t type t = Common.t
let t ~profile ~x = let t ~profile ~x =
Common.t ~profile >>= fun t -> Common.t ~profile >>| fun t ->
return { t with targets = Target.add t.targets x } { t with targets = Target.add t.targets x }
end end
type t = Default of Default.t | Opam of Opam.t type t = Default of Default.t | Opam of Opam.t
@ -165,7 +164,7 @@ let t ?x ?profile:cmdline_profile () =
>>= fun profile -> >>= fun profile ->
let profile = Option.value cmdline_profile ~default:profile in let profile = Option.value cmdline_profile ~default:profile in
multi_field "context" (Context.t ~profile ~x) multi_field "context" (Context.t ~profile ~x)
>>= fun contexts -> >>| fun contexts ->
let defined_names = ref String.Set.empty in let defined_names = ref String.Set.empty in
let { merlin_context; contexts; env } = let { merlin_context; contexts; env } =
let init = let init =
@ -205,11 +204,10 @@ let t ?x ?profile:cmdline_profile () =
else else
None None
in in
return { merlin_context
{ merlin_context ; contexts = List.rev contexts
; contexts = List.rev contexts ; env
; env }
}
let t ?x ?profile () = fields (t ?x ?profile ()) let t ?x ?profile () = fields (t ?x ?profile ())