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 ->
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 })
])

13
src/config.ml
View File

@ -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

55
src/dune_project.ml
View File

@ -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 =

52
src/inline_tests.ml
View File

@ -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 =

7
src/installed_dune_file.ml
View File

@ -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 =

10
src/jbuild.ml
View File

@ -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 \

20
src/ordered_set_lang.ml
View File

@ -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

25
src/preprocessing.ml
View File

@ -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

9
src/promotion.ml
View File

@ -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"

58
src/workspace.ml
View File

@ -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 ())