Start implementing .hmh parsing

BranchTaken · Mar 7, 2022 · ac372ec · ac372ec
1 parent 5288a70
commit ac372ec
Show file tree

Hide file tree

Showing 2 changed files with 125 additions and 32 deletions.
diff --git a/bootstrap/bin/hocc/hocc.ml b/bootstrap/bin/hocc/hocc.ml
@@ -26,14 +26,48 @@ let parse_hmhi path =
       Stdlib.exit 1
     end
 
+let parse_hmh path =
+  match File.of_path path with
+  | Ok f -> begin
+      let stream = File.Stream.of_file f in
+      let text = Text.of_bytes_stream ~path stream in
+      let scanner = Scan.init text in
+      let _scanner', hmh = Parse.hmh scanner in
+      match hmh with
+      | Error errors -> begin
+          List.iter (List.sort errors ~cmp:Parse.Error.cmp) ~f:(fun error ->
+            File.Fmt.stderr |> Parse.Error.pp error |> ignore
+          );
+          Stdlib.exit 1
+        end
+      | Ok hmh -> hmh
+    end
+  | Error err -> begin
+      File.Fmt.stderr
+      |> Fmt.fmt "hocc: File.of_path " |> Path.pp path |> Fmt.fmt ": "
+      |> Fmt.fmt (File.Error.to_string err)
+      |> Fmt.fmt "\n"
+      |> ignore;
+      Stdlib.exit 1
+    end
+
 let _ =
   let conf = Conf.of_argv Os.argv in
   (* File.Fmt.stdout |> Fmt.fmt "XXX hocc: conf=" |> Conf.pp conf |> Fmt.fmt "\n" |> ignore; *)
-  let path = Path.join [
+  let hmhi_path = Path.join [
     (Conf.srcdir conf);
     Path.of_segment (Path.Segment.join [
       (Conf.module_ conf);
       Option.value_hlt Path.(basename (of_string ".hmhi"))
     ]);
   ] in
-  parse_hmhi path
+  let _ = parse_hmhi hmhi_path in
+  let hmh_path = Path.join [
+    (Conf.srcdir conf);
+    Path.of_segment (Path.Segment.join [
+      (Conf.module_ conf);
+      Option.value_hlt Path.(basename (of_string ".hmh"))
+    ]);
+  ] in
+  let _ = parse_hmh hmh_path in
+  ()
diff --git a/bootstrap/bin/hocc/parse.ml b/bootstrap/bin/hocc/parse.ml
@@ -72,7 +72,7 @@ and token =
   | Token of {token: Scan.Token.t; cident: cident; of_type: of_type; prec_ref: prec_ref}
 and sep =
   | SepSemi of {semi: Scan.Token.t}
-  | SepLineSep of {line_sep: Scan.Token.t}
+  | SepLineDelim of {line_delim: Scan.Token.t}
 and codes_tl =
   | CodesTl of {sep: sep; codes: codes; codes_tl: codes_tl}
   | CodesTlEpsilon
@@ -121,7 +121,8 @@ and stmts_tl =
   | StmtsTlEpsilon
 and stmts =
   | Stmts of {stmt: stmt; stmts_tl: stmts_tl}
-and hocc = {hocc: Scan.Token.t; stmts: stmts}
+and hocc =
+  | Hocc of {hocc: Scan.Token.t; stmts: stmts}
 and eoi =
   | Eoi of {token: Scan.Token.t}
 and matter =
@@ -141,44 +142,103 @@ type ctx = {
 }
 
 let next {scanner; errs} =
-  let scanner', token = Scan.next scanner in
-  let errs' = List.fold (Scan.Token.malformations token) ~init:errs ~f:(fun accum mal ->
+  let scanner', tok = Scan.next scanner in
+  let errs' = List.fold (Scan.Token.malformations tok) ~init:errs ~f:(fun accum mal ->
     Error.init_mal mal :: accum) in
-  {scanner=scanner'; errs=errs'}, token
+  {scanner=scanner'; errs=errs'}, tok
 
 let err msg {scanner; errs} =
   {scanner; errs=(Error.init_scanner scanner msg) :: errs}
 
-let err_token token msg {scanner; errs} =
-  {scanner; errs=(Error.init_token token msg) :: errs}
+let err_token tok msg {scanner; errs} =
+  {scanner; errs=(Error.init_token tok msg) :: errs}
 
-let rec eoi ctx =
-  let ctx', token = next ctx in
-  match token with
-  | HmcToken {atok=Hmc.Scan.AbstractToken.Tok_end_of_input; _} -> ctx', Some (Eoi {token})
+(* Map optional subtree result, passing the resulting ctx in to enable tail recursion. *)
+let mapr ~child ~f ctx =
+  let ctx', child_opt = child ctx in
+  match child_opt with
+  | None -> ctx', None
+  | Some c -> f ctx' c
+
+(* Map optional subtree result, without support for tail recursion. *)
+let map ~child ~f ctx =
+  mapr ~child ~f:(fun ctx' c -> ctx', Some (f c)) ctx
+
+let rec xxx () = () (* XXX *)
+
+and sep ctx =
+  let ctx', tok = next ctx in
+  match tok with
+  | HmcToken {atok=Hmc.Scan.AbstractToken.Tok_semi; _} -> ctx', Some (SepSemi {semi=tok})
+  | HmcToken {atok=Hmc.Scan.AbstractToken.Tok_line_delim; _} ->
+    ctx', Some (SepLineDelim {line_delim=tok})
+  | _ -> ctx, None
+
+and code ctx =
+  ctx, None (* XXX *)
+
+and prec ctx =
+  ctx, None (* XXX *)
+
+and token ctx =
+  ctx, None (* XXX *)
+
+and nonterm ctx =
+  ctx, None (* XXX *)
+
+and stmt ctx =
+  let ctx', tok = next ctx in
+  match tok with
+  | HoccToken {atok=Scan.AbstractToken.Tok_prec; _} ->
+    map ~child:prec ~f:(fun prec -> StmtPrec {prec}) ctx'
+  | HoccToken {atok=Scan.AbstractToken.Tok_token; _} ->
+    map ~child:token ~f:(fun token -> StmtToken {token}) ctx'
+  | HoccToken {atok=Scan.AbstractToken.Tok_nonterm; _} ->
+    map ~child:nonterm ~f:(fun nonterm -> StmtNonterm {nonterm}) ctx'
+  | _ -> map ~child:code ~f:(fun code -> StmtCode {code}) ctx
+
+and stmts_tl ctx =
+  let ctx', sep_opt = sep ctx in
+  match sep_opt with
+  | Some sep -> begin
+      mapr ~child:stmt ~f:(fun ctx' stmt ->
+        mapr ~child:stmts_tl ~f:(fun ctx' stmts_tl ->
+          ctx', Some (StmtsTl {sep; stmt; stmts_tl})
+        ) ctx'
+      ) ctx'
+    end
+  | None -> ctx', Some StmtsTlEpsilon
+
+and stmts ctx =
+  mapr ~child:stmt ~f:(fun ctx' stmt ->
+    mapr ~child:stmts_tl ~f:(fun ctx' stmts_tl ->
+      ctx', Some (Stmts {stmt; stmts_tl})
+    ) ctx'
+  ) ctx
+
+and hocc ctx =
+  let ctx', tok = next ctx in
+  match tok with
+  | HoccToken {atok=Scan.AbstractToken.Tok_hocc; _} ->
+    map ~child:stmts ~f:(fun stmts -> Hocc {hocc=tok; stmts}) ctx'
+  | _ -> err_token tok "Expected hocc" ctx, None
+
+and eoi ctx =
+  let ctx', tok = next ctx in
+  match tok with
+  | HmcToken {atok=Hmc.Scan.AbstractToken.Tok_end_of_input; _} -> ctx', Some (Eoi {token=tok})
   | _ -> err "Unexpected token before eoi" ctx, None
 
 and matter ctx =
-  let ctx', token = next ctx in
-  match token with
+  let ctx', tok = next ctx in
+  match tok with
   | HoccToken _
   | HmcToken {atok=Hmc.Scan.AbstractToken.Tok_end_of_input; _} -> ctx, MatterEpsilon
   | HmcToken _ -> begin
       let ctx', matter_rchild = matter ctx' in
-      ctx', Matter {token; matter=matter_rchild}
+      ctx', Matter {token=tok; matter=matter_rchild}
     end
 
-(*
-and hocc ctx =
-  let ctx', token = next ctx in
-  match token with
-  let hocc_opt, errs = match token with
-    | HoccToken {atok=Scan.AbstractToken.Tok_hocc; _} -> Some token, errs
-    | _ -> None, ((Error.init_token token "Expected hocc") :: errs)
-  in
-*)
-
-(*
 and hmh scanner =
   let ctx = {scanner; errs=[]} in
   let ctx', prelude = matter ctx in
@@ -189,15 +249,14 @@ and hmh scanner =
   | None, _
   | _, None -> ctx'.scanner, Error ctx.errs
   | Some hocc, Some eoi -> ctx'.scanner, Ok (Hmh {prelude; hocc; postlude; eoi})
-*)
 
 and hmhi scanner =
   let ctx = {scanner; errs=[]} in
   let ctx', prelude = matter ctx in
-  let ctx', token = next ctx' in
-  let hocc_opt, ctx' = match token with
-    | HoccToken {atok=Scan.AbstractToken.Tok_hocc; _} -> Some token, ctx'
-    | _ -> None, err_token token "Expected hocc" ctx
+  let ctx', tok = next ctx' in
+  let hocc_opt, ctx' = match tok with
+    | HoccToken {atok=Scan.AbstractToken.Tok_hocc; _} -> Some tok, ctx'
+    | _ -> None, err_token tok "Expected hocc" ctx
   in
   let ctx', postlude = matter ctx' in
   let ctx', eoi_opt = eoi ctx' in