feat(parse): parse the grammar with recursive descent

Turns tokens into the AST, and consults suggest at each failure point so an
unknown declaration or field offers the nearest valid name.

lib/parse.ml

@@ -0,0 +1,260 @@
+open Ast
+
+type p = { toks : Lexer.t array; mutable pos : int }
+
+let stmt_keywords =
+  [ "project"; "set"; "append"; "option"; "include"; "subdir"; "if"; "check"; "pkg";
+    "config_header"; "message" ]
+
+let block_kinds = [ "toolchain"; "lib"; "shared"; "bin"; "test"; "rule"; "install" ]
+let check_kinds = [ "header"; "func"; "symbol"; "sizeof"; "compiles" ]
+
+let peek p = p.toks.(p.pos)
+let kind p = (peek p).Lexer.kind
+let span p = (peek p).Lexer.span
+let advance p = if p.pos < Array.length p.toks - 1 then p.pos <- p.pos + 1
+
+let bump p =
+  let t = peek p in
+  advance p;
+  t
+
+let rec skip_nl p = match kind p with Lexer.Newline -> advance p; skip_nl p | _ -> ()
+
+let expected p what =
+  Diag.error ~span:(span p) "expected %s, found %s" what (Lexer.describe (kind p))
+
+let word_value p =
+  match kind p with
+  | Lexer.Word w -> let s = span p in advance p; { text = w; span = s; quoted = false }
+  | Lexer.Str w -> let s = span p in advance p; { text = w; span = s; quoted = true }
+  | _ -> expected p "a value"
+
+let is_value p = match kind p with Lexer.Word _ | Lexer.Str _ -> true | _ -> false
+
+let name_value p what =
+  match kind p with
+  | Lexer.Word w -> let s = span p in advance p; { text = w; span = s; quoted = false }
+  | _ -> expected p what
+
+let eat_lbrace p =
+  skip_nl p;
+  match kind p with Lexer.Lbrace -> advance p | _ -> expected p "'{'"
+
+let end_of_line p =
+  match kind p with
+  | Lexer.Newline | Lexer.Eof -> ()
+  | Lexer.Rbrace -> ()
+  | _ -> expected p "end of line"
+
+let values_until_eol p =
+  let acc = ref [] in
+  while is_value p do acc := word_value p :: !acc done;
+  end_of_line p;
+  List.rev !acc
+
+let at_word p w = match kind p with Lexer.Word x -> x = w | _ -> false
+
+(* conditions: or > and > cmp > not > primary *)
+let rec expr p = or_expr p
+
+and or_expr p =
+  let l = ref (and_expr p) in
+  while at_word p "or" do advance p; l := Or (!l, and_expr p) done;
+  !l
+
+and and_expr p =
+  let l = ref (cmp_expr p) in
+  while at_word p "and" do advance p; l := And (!l, cmp_expr p) done;
+  !l
+
+and cmp_expr p =
+  let l = unary p in
+  match kind p with
+  | Lexer.Word (("==" | "!=") as op) -> (
+      advance p;
+      let r = word_value p in
+      match l with
+      | Atom a -> Cmp (a, op, r)
+      | _ -> Diag.error ~span:r.span "%s compares values, not conditions" op)
+  | _ -> l
+
+and unary p =
+  if at_word p "not" then (let s = span p in advance p; Not (unary p, s)) else primary p
+
+and primary p =
+  match kind p with
+  | Lexer.Lparen ->
+      advance p;
+      let e = expr p in
+      (match kind p with Lexer.Rparen -> advance p | _ -> expected p "')'");
+      e
+  | Lexer.Word _ | Lexer.Str _ -> Atom (word_value p)
+  | _ -> expected p "a condition"
+
+let rec fitems p =
+  let acc = ref [] in
+  let stop = ref false in
+  while not !stop do
+    skip_nl p;
+    match kind p with
+    | Lexer.Rbrace -> advance p; stop := true
+    | Lexer.Eof -> Diag.error ~span:(span p) "unclosed block"
+    | Lexer.Word "if" -> let a, b = fif p fitems in acc := FIf (a, b) :: !acc
+    | Lexer.Word key ->
+        let kspan = span p in
+        advance p;
+        let values = values_until_eol p in
+        if values = [] then
+          Diag.error ~span:kspan ~hint:"write a value after the field name"
+            "field %S has no value" key;
+        acc := FField { key; kspan; values } :: !acc
+    | _ -> expected p "a field name or '}'"
+  done;
+  List.rev !acc
+
+and fif : 'a. p -> (p -> 'a list) -> (expr * 'a list) list * 'a list =
+  fun p body ->
+   advance p;
+   let cond = expr p in
+   eat_lbrace p;
+   let taken = body p in
+   let arms = ref [ (cond, taken) ] in
+   let fallback = ref [] in
+   let stop = ref false in
+   while not !stop do
+     let save = p.pos in
+     skip_nl p;
+     if at_word p "else" then begin
+       advance p;
+       if at_word p "if" then begin
+         advance p;
+         let c = expr p in
+         eat_lbrace p;
+         arms := (c, body p) :: !arms
+       end
+       else begin
+         eat_lbrace p;
+         fallback := body p;
+         stop := true
+       end
+     end
+     else (p.pos <- save; stop := true)
+   done;
+   (List.rev !arms, !fallback)
+
+let check_stmt p kspan =
+  let what = name_value p "a check kind" in
+  let c =
+    match what.text with
+    | "header" -> Header (word_value p)
+    | "sizeof" -> Sizeof (word_value p)
+    | "func" ->
+        let f = word_value p in
+        if at_word p "in" then (advance p; Func (f, Some (word_value p))) else Func (f, None)
+    | "symbol" ->
+        let s = word_value p in
+        if not (at_word p "in") then
+          Diag.error ~span:(span p) ~hint:"write: check symbol NAME in HEADER" "expected 'in'";
+        advance p;
+        Symbol (s, word_value p)
+    | "compiles" ->
+        let n = word_value p in
+        let body = word_value p in
+        if not body.quoted then
+          Diag.error ~span:body.span "the program for 'check compiles' must be a quoted string";
+        Compiles (n, body)
+    | other ->
+        Diag.error ~span:what.span ~hint:(Suggest.hint other check_kinds) "unknown check %S" other
+  in
+  end_of_line p;
+  Check (c, kspan)
+
+let rec stmt p =
+  let t = peek p in
+  match t.Lexer.kind with
+  | Lexer.Word "project" ->
+      advance p;
+      let name = name_value p "the project name" in
+      end_of_line p;
+      Project name
+  | Lexer.Word "set" ->
+      advance p;
+      let n = name_value p "a variable name" in
+      Set (n, values_until_eol p)
+  | Lexer.Word "append" ->
+      advance p;
+      let n = name_value p "a variable name" in
+      Append (n, values_until_eol p)
+  | Lexer.Word "option" ->
+      advance p;
+      let n = name_value p "an option name" in
+      let ty = name_value p "the option type (bool, string or path)" in
+      if not (List.mem ty.text [ "bool"; "string"; "path" ]) then
+        Diag.error ~span:ty.span ~hint:(Suggest.hint ty.text [ "bool"; "string"; "path" ])
+          "unknown option type %S" ty.text;
+      Option (n, ty, values_until_eol p)
+  | Lexer.Word "include" -> advance p; let v = word_value p in end_of_line p; Include v
+  | Lexer.Word "subdir" -> advance p; let v = word_value p in end_of_line p; Subdir v
+  | Lexer.Word "config_header" -> advance p; let v = word_value p in end_of_line p; ConfigHeader v
+  | Lexer.Word "message" ->
+      advance p;
+      let lvl = name_value p "a message level (info, warn or error)" in
+      if not (List.mem lvl.text [ "info"; "warn"; "error" ]) then
+        Diag.error ~span:lvl.span ~hint:(Suggest.hint lvl.text [ "info"; "warn"; "error" ])
+          "unknown message level %S" lvl.text;
+      Message (lvl, values_until_eol p)
+  | Lexer.Word "check" -> advance p; check_stmt p t.Lexer.span
+  | Lexer.Word "pkg" ->
+      advance p;
+      let n = word_value p in
+      let c = if is_value p then Some (word_value p) else None in
+      end_of_line p;
+      Pkg (n, c, t.Lexer.span)
+  | Lexer.Word "if" -> let arms, els = fif p stmts_body in If (arms, els)
+  | Lexer.Word k when List.mem k block_kinds ->
+      advance p;
+      let bname, nspan =
+        if k = "toolchain" then ("", t.Lexer.span)
+        else
+          let v = name_value p (Printf.sprintf "a name for this %s" k) in
+          (v.text, v.span)
+      in
+      eat_lbrace p;
+      Blk { kind = k; kspan = t.Lexer.span; bname; nspan; items = fitems p }
+  | Lexer.Word other ->
+      Diag.error ~span:t.Lexer.span
+        ~hint:(Suggest.hint other (stmt_keywords @ block_kinds))
+        "unknown declaration %S" other
+  | k -> Diag.error ~span:t.Lexer.span "expected a declaration, found %s" (Lexer.describe k)
+
+and stmts_body p =
+  let acc = ref [] in
+  let stop = ref false in
+  while not !stop do
+    skip_nl p;
+    match kind p with
+    | Lexer.Rbrace -> advance p; stop := true
+    | Lexer.Eof -> Diag.error ~span:(span p) "unclosed block"
+    | _ -> acc := stmt p :: !acc
+  done;
+  List.rev !acc
+
+let program p =
+  let acc = ref [] in
+  let stop = ref false in
+  while not !stop do
+    skip_nl p;
+    match kind p with Lexer.Eof -> stop := true | _ -> acc := stmt p :: !acc
+  done;
+  List.rev !acc
+
+let string ~file src =
+  Diag.register file src;
+  let toks = Array.of_list (Lexer.tokens ~file src) in
+  program { toks; pos = 0 }
+
+let file path =
+  match Fs.read path with
+  | exception Sys_error m -> Diag.error "%s" m
+  | src -> string ~file:path src