Merge pull request #1068 from ocaml/more-applicative-syntax

More applicative syntax

src/action.ml

@@ -368,12 +368,13 @@ module Unexpanded = struct
   include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Uast)
 
   let t =
-    let open Sexp.Of_sexp in
-    peek_exn >>= function
-    | Template _ | Atom _ | Quoted_string _ as sexp ->
-      of_sexp_errorf (Sexp.Ast.loc sexp)
-        "if you meant for this to be executed with bash, write (bash \"...\") instead"
-    | List _ -> t
+    if_list
+      ~then_:t
+      ~else_:
+        (loc >>| fun loc ->
+         of_sexp_errorf
+           loc
+           "if you meant for this to be executed with bash, write (bash \"...\") instead")
 
   let check_mkdir loc path =
     if not (Path.is_managed path) then

src/inline_tests.ml

@@ -130,22 +130,22 @@ include Sub_system.Register_end_point(
       open Stanza.Of_sexp
 
       let parse =
-        eos >>= function
-        | true -> loc >>| empty
-        | false ->
-          record
-            (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
-             })
+        if_eos
+          ~then_:(loc >>| empty)
+          ~else_:
+            (record
+               (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 =

src/jbuild.ml

@@ -225,11 +225,9 @@ module Pps_and_flags = struct
   end
 
   let t =
-    Syntax.get_exn Stanza.syntax >>= fun ver ->
-    if ver < (1, 0) then
-      Jbuild_syntax.t
-    else
-      Dune_syntax.t
+    switch_file_kind
+      ~jbuild:Jbuild_syntax.t
+      ~dune:Dune_syntax.t
 end
 
 module Bindings = struct
@@ -255,10 +253,11 @@ module Bindings = struct
 
   let singleton x = [Unnamed x]
 
-  let t elem =
-    Stanza.file_kind () >>= function
-    | Jbuild -> list (elem >>| fun x -> Unnamed x)
-    | Dune -> parens_removed_in_dune (
+  let jbuild elem =
+    list (elem >>| fun x -> Unnamed x)
+
+  let dune elem =
+    parens_removed_in_dune (
       let%map l =
         repeat
           (if_paren_colon_form
@@ -283,6 +282,11 @@ module Bindings = struct
       in
       loop String.Set.empty [] l)
 
+  let t elem =
+    switch_file_kind
+      ~jbuild:(jbuild elem)
+      ~dune:(dune elem)
+
   let sexp_of_t sexp_of_a bindings =
     Sexp.List (
       List.map bindings ~f:(function
@@ -323,10 +327,9 @@ module Dep_conf = struct
            Source_tree x)
         ]
     in
-    peek_exn >>= function
-    | Template _ | Atom _ | Quoted_string _ ->
-      String_with_vars.t >>| fun x -> File x
-    | List _ -> t
+    if_list
+      ~then_:t
+      ~else_:(String_with_vars.t >>| fun x -> File x)
 
   open Sexp
   let sexp_of_t = function
@@ -1028,12 +1031,13 @@ module Executables = struct
       Sexp.Of_sexp.enum simple_representations
 
     let t =
-      peek_exn >>= function
-      | List _ ->
-        enter (let%map mode = Mode_conf.t
-               and kind = Binary_kind.t in
-               { mode; kind })
-      | _ -> simple
+      if_list
+        ~then_:
+          (enter
+             (let%map mode = Mode_conf.t
+              and kind = Binary_kind.t in
+              { mode; kind }))
+        ~else_:simple
 
     let simple_sexp_of_t link_mode =
       let is_ok (_, candidate) =
@@ -1397,11 +1401,9 @@ module Rule = struct
         "S-expression of the form (<atom> ...) expected"
 
   let t =
-    Syntax.get_exn Stanza.syntax >>= fun ver ->
-    if ver < (1, 0) then
-      jbuild_syntax
-    else
-      dune_syntax
+    switch_file_kind
+      ~jbuild:jbuild_syntax
+      ~dune:dune_syntax
 
   type lex_or_yacc =
     { modules : string list
@@ -1443,11 +1445,9 @@ module Rule = struct
             }))
 
   let ocamllex =
-    Syntax.get_exn Stanza.syntax >>= fun ver ->
-    if ver < (1, 0) then
-      ocamllex_jbuild
-    else
-      ocamllex_dune
+    switch_file_kind
+      ~jbuild:ocamllex_jbuild
+      ~dune:ocamllex_dune
 
   let ocamlyacc = ocamllex
 

src/stanza.ml

@@ -22,8 +22,7 @@ end
 
 let file_kind () =
   let open Sexp.Of_sexp in
-  Syntax.get_exn syntax >>| fun ver ->
-  if ver < (1, 0) then File_kind.Jbuild else Dune
+  Syntax.get_exn syntax >>| File_kind.of_syntax
 
 module Of_sexp = struct
   include Sexp.Of_sexp
@@ -45,11 +44,15 @@ module Of_sexp = struct
             }
         | _ -> None)
 
+  let switch_file_kind ~jbuild ~dune =
+    file_kind () >>= function
+    | Jbuild -> jbuild
+    | Dune -> dune
+
   let parens_removed_in_dune_generic ~is_record t =
-    Syntax.get_exn syntax >>= fun ver ->
-    if ver < (1, 0) then
-      enter t
-    else
+    switch_file_kind
+      ~jbuild:(enter t)
+      ~dune:(
       try_
         t
         (function
@@ -70,6 +73,7 @@ module Of_sexp = struct
               (function
                 | Parens_no_longer_necessary _ as exn -> raise exn
                 | _ -> raise exn))
+    )
 
   let record parse =
     parens_removed_in_dune_generic (fields parse) ~is_record:true

src/stanza.mli

@@ -56,4 +56,12 @@ module Of_sexp : sig
       displays a nice error messages when parentheses are used in dune
       files. *)
   val parens_removed_in_dune : 'a t -> 'a t
+
+  (** Use a different parser depending on the syntax in the current file.
+      If the syntax version is strictly less than `(1, 0)`, use `jbuild`.
+      Otherwise use `dune`. *)
+  val switch_file_kind :
+   jbuild:('a, 'b) parser ->
+   dune:('a, 'b) parser ->
+   ('a, 'b) parser
 end

src/stdune/path.ml

@@ -602,17 +602,17 @@ let of_string ?error_loc s =
       make_local_path (Local.of_string s ?error_loc)
 
 let t =
-  Sexp.Of_sexp.(
-    peek_exn >>= function
-    | Template _ | Atom _ | Quoted_string _ ->
+  let open Sexp.Of_sexp in
+  if_list
+    ~then_:
+      (sum
+         [ "In_build_dir"  , Local.t    >>| in_build_dir
+         ; "In_source_tree", Local.t    >>| in_source_tree
+         ; "External"      , External.t >>| external_
+         ])
+    ~else_:
       (* necessary for old build dirs *)
-      plain_string (fun ~loc:_ s -> of_string s)
-    | List _ ->
-      sum
-        [ "In_build_dir"  , Local.t    >>| in_build_dir
-        ; "In_source_tree", Local.t    >>| in_source_tree
-        ; "External"      , External.t >>| external_
-        ])
+      (plain_string (fun ~loc:_ s -> of_string s))
 
 let sexp_of_t t =
   let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in

src/stdune/sexp.mli

@@ -117,9 +117,8 @@ module Of_sexp : sig
   (** Return the location of the list currently being parsed. *)
   val loc : (Loc.t, _) parser
 
-  (** End of sequence condition. Returns [true] iff they are no more
-      S-expressions to parse *)
-  val eos : (bool, _) parser
+  (** End of sequence condition. Uses [then_] if there are no more
+      S-expressions to parse, [else_] otherwise. *)
   val if_eos : then_:('a, 'b) parser -> else_:('a, 'b) parser -> ('a, 'b) parser
 
   (** If the next element of the sequence is a list, parse it with

src/string_with_vars.ml

@@ -113,13 +113,10 @@ let t =
     | Quoted_string (loc, s) -> literal ~quoted:true ~loc s
     | List (loc, _) -> Sexp.Of_sexp.of_sexp_error loc "Unexpected list"
   in
-  Syntax.get_exn Stanza.syntax >>= fun syntax_version ->
-  let template =
-    match syntax_version with
-    | (0, _) -> jbuild
-    | (_, _) -> dune
+  let template_parser = Stanza.Of_sexp.switch_file_kind ~jbuild ~dune in
+  let%map syntax_version = Syntax.get_exn Stanza.syntax
+  and template = template_parser
   in
-  template >>| fun template ->
   {template; syntax_version}
 
 let loc t = t.template.loc

src/workspace.ml

@@ -76,12 +76,13 @@ module Context = struct
       }
 
     let t ~profile ~x =
-      Common.t ~profile >>= fun base ->
-      field "switch" string >>= fun switch ->
-      let%map name = field "name" Name.t ~default:switch
+      let%map base = Common.t ~profile
+      and switch = field "switch" string
+      and name = field_o "name" Name.t
       and root = field_o "root" string
       and merlin = field_b "merlin"
       in
+      let name = Option.value ~default:switch name in
       let base = { base with targets = Target.add base.targets x } in
       { base
       ; switch
@@ -116,14 +117,14 @@ module Context = struct
       ]
 
   let t ~profile ~x =
-    Syntax.get_exn syntax >>= function
-    | (0, _) ->
-      (* jbuild-workspace files *)
-      (peek_exn >>= function
-       | List (_, List _ :: _) ->
-         Sexp.Of_sexp.record (Opam.t ~profile ~x) >>| fun x -> Opam x
-       | _ -> t ~profile ~x)
-    | _ -> t ~profile ~x
+    switch_file_kind
+      ~jbuild:
+        (* jbuild-workspace files *)
+        (peek_exn >>= function
+         | List (_, List _ :: _) ->
+           Sexp.Of_sexp.record (Opam.t ~profile ~x) >>| fun x -> Opam x
+         | _ -> t ~profile ~x)
+      ~dune:(t ~profile ~x)
 
   let name = function
     | Default _ -> "default"