Strengthen the parsing of the (lang ...) line

It now has to be the first line of the dune-project file and the
lexical conventions are stricter than the rest of the syntax.

This will allow making changes to the lexical conventions of the
language in the future.

Signed-off-by: Jeremie Dimino <jdimino@janestreet.com>

src/config.ml

@@ -111,7 +111,7 @@ let user_config_file =
   Path.relative (Path.of_string Xdg.config_dir) "dune/config"
 
 let load_config_file p =
-  t (Io.Sexp.load_many_as_one p)
+  t (Io.Sexp.load p ~mode:Many_as_one)
 
 let load_user_config_file () =
   if Path.exists user_config_file then

src/dune_lexer.mli

@@ -0,0 +1,10 @@
+(** Returns [true] if the input starts with "(* -*- tuareg -*- *)" *)
+val is_script : Lexing.lexbuf -> bool
+
+type first_line =
+  { lang    : Loc.t * string
+  ; version : Loc.t * string
+  }
+
+(** Parse the first line of a dune-project file. *)
+val first_line : Lexing.lexbuf -> first_line

src/dune_lexer.mll

@@ -1,3 +1,64 @@
+{
+type first_line =
+  { lang    : Loc.t * string
+  ; version : Loc.t * string
+  }
+
+let make_loc lexbuf : Loc.t =
+  { start = Lexing.lexeme_start_p lexbuf
+  ; stop  = Lexing.lexeme_end_p   lexbuf
+  }
+
+let invalid_lang_line start lexbuf =
+  lexbuf.Lexing.lex_start_p <- start;
+  Loc.fail_lex lexbuf
+    "Invalid first line, expected: (lang <lang> <version>)"
+}
+
+let newline   = '\r'? '\n'
+let blank     = [' ' '\t']
+let atom_char = [^';' '(' ')' '"' '#' '|' '\000'-'\032']
+
 rule is_script = parse
   | "(* -*- tuareg -*- *)" { true }
   | ""                     { false }
+
+and first_line = parse
+  | '(' blank* "lang"
+    { let start = Lexing.lexeme_start_p lexbuf in
+      let lang    = atom start lexbuf in
+      let version = atom start lexbuf in
+      first_line_end start lexbuf;
+      { lang; version }
+    }
+  | ""
+    { let start = Lexing.lexeme_start_p lexbuf in
+      to_eol lexbuf;
+      invalid_lang_line start lexbuf
+    }
+
+and atom start = parse
+  | blank+
+    { atom start lexbuf
+    }
+  | atom_char+ as s
+    { (make_loc lexbuf, s)
+    }
+  | _ | eof
+    { to_eol lexbuf;
+      invalid_lang_line start lexbuf
+    }
+
+and first_line_end start = parse
+  | blank* ')' blank* (newline | eof)
+    { ()
+    }
+  | ""
+    { to_eol lexbuf;
+      invalid_lang_line start lexbuf
+    }
+
+and to_eol = parse
+  | [^'\r' '\n']*
+    { ()
+    }

src/dune_project.ml

@@ -131,22 +131,6 @@ let anonymous =
 
 let filename = "dune-project"
 
-type lang =
-  | Dune_0_1
-
-let lang =
-  let name =
-    enum
-      [ ("dune", ()) ]
-  in
-  let version ver =
-    match string ver with
-    | "0.1" -> Dune_0_1
-    | _ ->
-      of_sexp_error ver "unsupported version of the dune language"
-  in
-  field_multi "lang" (name @> version @> nil) (fun () v -> v)
-
 let default_name ~dir ~packages =
   match Package.Name.Map.choose packages with
   | None -> Option.value_exn (Name.anonymous dir)
@@ -173,8 +157,7 @@ let name ~dir ~packages =
 
 let parse ~dir packages =
   record
-    (lang >>= fun Dune_0_1 ->
-     name ~dir ~packages >>= fun name ->
+    (name ~dir ~packages >>= fun name ->
      field_o "version" string >>= fun version ->
      return { lang = Dune (0, 1)
             ; name
@@ -185,8 +168,20 @@ let parse ~dir packages =
 
 let load_dune_project ~dir packages =
   let fname = Path.relative dir filename in
-  let sexp = Io.Sexp.load_many_as_one fname in
-  parse ~dir packages sexp
+  Io.with_lexbuf_from_file fname ~f:(fun lb ->
+    let { Dune_lexer. lang; version } = Dune_lexer.first_line lb in
+    (match lang with
+     | _, "dune" -> ()
+     | loc, s ->
+       Loc.fail loc "%s is not a supported langauge. \
+                     Only the dune language is supported." s);
+    (match version with
+     | _, "0.1" -> ()
+     | loc, s ->
+       Loc.fail loc "Unsupported version of the dune language. \
+                     The only supported version is 0.1." s);
+    let sexp = Sexp.Parser.parse lb ~mode:Many_as_one in
+    parse ~dir packages sexp)
 
 let make_jbuilder_project ~dir packages =
   { lang = Jbuilder

src/stdune/io.ml

@@ -82,16 +82,6 @@ let compare_files fn1 fn2 = String.compare (read_file fn1) (read_file fn2)
 let buf_len = 65_536
 
 module Sexp = struct
-  open Sexp
-
   let load ?lexer path ~mode =
     with_lexbuf_from_file path ~f:(Usexp.Parser.parse ~mode ?lexer)
-
-  let load_many_as_one ?lexer path =
-    match load ?lexer path ~mode:Many with
-    | [] -> Ast.List (Loc.in_file (Path.to_string path), [])
-    | x :: l ->
-      let last = Option.value (List.last l) ~default:x in
-      let loc = { (Ast.loc x) with stop = (Ast.loc last).stop } in
-      Ast.List (loc, x :: l)
 end

src/stdune/io.mli

@@ -28,7 +28,6 @@ val read_all : in_channel -> string
 
 module Sexp : sig
   val load : ?lexer:Usexp.Lexer.t -> Path.t -> mode:'a Sexp.Parser.Mode.t -> 'a
-  val load_many_as_one : ?lexer:Usexp.Lexer.t -> Path.t -> Sexp.Ast.t
 end
 
 (**/**)

src/usexp/usexp.ml

@@ -267,7 +267,7 @@ module Ast = struct
     if should_be_atom s then Atom (loc, A s)
     else Quoted_string (loc, s)
 
-let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _)) = loc
+  let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _)) = loc
 
   let rec remove_locs : t -> sexp = function
     | Atom (_, s) -> Atom s
@@ -306,19 +306,28 @@ module Parser = struct
 
   module Mode = struct
     type 'a t =
-      | Single : Ast.t t
-      | Many   : Ast.t list t
+      | Single      : Ast.t t
+      | Many        : Ast.t list t
+      | Many_as_one : Ast.t t
 
     let make_result : type a. a t -> Lexing.lexbuf -> Ast.t list -> a
       = fun t lexbuf sexps ->
         match t with
-        | Many -> sexps
-        | Single ->
+        | Single -> begin
           match sexps with
           | [sexp] -> sexp
           | [] -> error (make_loc lexbuf) "no s-expression found in input"
           | _ :: sexp :: _ ->
             error (Ast.loc sexp) "too many s-expressions found in input"
+        end
+        | Many -> sexps
+        | Many_as_one ->
+          match sexps with
+          | [] -> List (Loc.in_file lexbuf.lex_curr_p.pos_fname, [])
+          | x :: l ->
+            let last = List.fold_left l ~init:x ~f:(fun _ x -> x) in
+            let loc = { (Ast.loc x) with stop = (Ast.loc last).stop } in
+            List (loc, x :: l)
   end
 
   let rec loop depth lexer lexbuf acc =

src/usexp/usexp.mli

@@ -107,8 +107,9 @@ end
 module Parser : sig
   module Mode : sig
     type 'a t =
-      | Single : Ast.t t
-      | Many   : Ast.t list t
+      | Single      : Ast.t t
+      | Many        : Ast.t list t
+      | Many_as_one : Ast.t t
   end
 
   val parse