added much better error reporting

src/compiler/directive.ml

@@ -8,6 +8,8 @@ type directive =
   | Layout of layout_type
   | Primary of wire_color
 
+exception DirectiveError of string
+
 let parse_directive d s : directive = 
   let d = String.lowercase_ascii d in
   let s = String.lowercase_ascii s in
@@ -16,15 +18,15 @@ let parse_directive d s : directive =
     begin match s with 
     | "identity" -> Layout Identity 
     | "naive" -> Layout Naive
-    | _ -> failwith ("Unsupported layout type: " ^ s)
+    | _ -> raise @@ DirectiveError ("Unsupported layout type: " ^ s)
     end
   | "primary" -> 
     begin match s with 
     | "red" -> Primary Red 
     | "green" -> Primary Green 
-    | _ -> failwith ("Unsupported primary wire color: " ^ s)
+    | _ -> raise @@ DirectiveError ("Unsupported primary wire color: " ^ s)
     end
-  | _ -> failwith ("Unsupported directive: " ^ d)
+  | _ -> raise @@ DirectiveError ("Unsupported directive: " ^ d)
   end
 
 

src/main.ml

@@ -11,7 +11,7 @@ let optimize = true
   using comparison operations may not compile *)
 let optimize_b = true
 
-let usage_msg = "combc [--output-json] <file1>"
+let usage_msg = "combc [--output-json] <file>"
 let input_file = ref None
 let output_json = ref false 
 let speclist = [("--output-json", Arg.Set output_json, "Output json instead of blueprint string")] 
@@ -25,16 +25,10 @@ let () =
   let name = 
     begin match !input_file with 
     | Some s -> s
-    | None -> failwith ("Missing input file, usage: " ^ usage_msg)
+    | None -> prerr_endline ("Missing input file, usage:\n" ^ usage_msg); exit 1;
     end in
 
-  let code = 
-  try 
-    Core_kernel.In_channel.read_all name
-  with Sys_error s -> failwith s 
-  in
-
-  let directives, assignment_list = parse code in 
+  let directives, assignment_list = parse name in  
   let cfg = config_of_directives directives in 
   set_config cfg;
 

src/parser/dune

@@ -1,9 +1,34 @@
 (library
  (name parse)
- (libraries ast compiler))
+ (libraries ast compiler menhirLib))
 
 (ocamllex lexer)
 
 (menhir
  (modules parser)
- (flags --explain))
+ ; (flags --explain --table)
+ (flags -lg 1 -la 1 -lc 2)
+)
+
+(rule
+  (action
+    (with-stdout-to unitActionsParser.mly
+      (run menhir
+        %{dep:parser.mly}
+        --only-preprocess-u
+))))
+
+(menhir
+  (modules unitActionsParser)
+  (flags --table --external-tokens Parser)
+)
+
+
+(rule
+  (action (with-stdout-to errors.ml
+    (run menhir
+      %{dep:parser.mly}
+      --compile-errors %{dep:errors.messages}
+    )
+  ))
+)

src/parser/errors.messages

@@ -0,0 +1,3 @@
+toplevel: PLUS
+
+Missing left operand and right operand 

src/parser/lexer.mll

@@ -12,9 +12,9 @@
       pos_lnum = 1;
     }
 
-  let unexpected_char lexbuf (c:char) : 'a =
+  let unexpected_char lexbuf (c:char) (d:int) : 'a =
     raise (Lexer_error (
-        Printf.sprintf "Unexpected character: '%c'" c))
+        Printf.sprintf "Unexpected character at position %d: '%c'" d c))
 }
 
 let lowercase = ['a'-'z']
@@ -26,16 +26,17 @@ let num = '-'?digit+
 let identifer = (character | ichar) (character | ichar | digit)*
 let signal = uppercase
 let single_case_word = (uppercase | ichar)(uppercase | ichar)+ | (lowercase | ichar)(lowercase | ichar)+
-let whitespace = ['\t' ' ' '\r' '\n']
+let whitespace = ['\t' ' ' '\r']
 let circuit_bind = "circuit"(whitespace+)
 let newline = '\n' | "\r\n" | eof
 let comment = "//"[^'\r''\n']*newline
 let directive = '#'
 
 rule token = parse
   | eof         { EOF }
-  | comment     
   | whitespace+ { token lexbuf }  (* skip whitespace *)
+  | comment     
+  | '\n'        { MenhirLib.LexerUtil.newline lexbuf; token lexbuf }
   | signal { VAR (lexeme lexbuf) }
   | num    { LIT (Int32.of_string (lexeme lexbuf)) }
   | circuit_bind { CIRCUIT_BIND }
@@ -75,4 +76,4 @@ rule token = parse
   | "==="       { LEQ }
   | "!=="       { LNEQ }
   | single_case_word  { WORD (lexeme lexbuf) }
-  | _ as c      { unexpected_char lexbuf c }
+  | _ as c      { unexpected_char lexbuf c (lexeme_start lexbuf) }

src/parser/parse.ml

@@ -1,11 +1,87 @@
 open Ast
 open Compiler.Directive
+open Printf
+module L = MenhirLib.LexerUtil
 module P = Parser
+module E = MenhirLib.ErrorReports
+module I = UnitActionsParser.MenhirInterpreter
 
-let parse (input: string) : directive list * assignment list =
-  try
-    (* Lexer.reset_lexbuf filename buf ; *)
-    P.toplevel Lexer.token (Lexing.from_string input)
-  with P.Error ->
-    failwith
-      (Printf.sprintf "Parse error")
+let env checkpoint =
+  match checkpoint with
+  | I.HandlingError env ->
+      env
+  | _ ->
+      assert false
+
+let state checkpoint : int =
+  match I.top (env checkpoint) with
+  | Some (I.Element (s, _, _, _)) ->
+      I.number s
+  | None -> 0
+
+let show text positions =
+  E.extract text positions
+  |> E.sanitize
+  |> E.compress
+  |> E.shorten 20 (* max width 43 *)
+
+let get text checkpoint i =
+  match I.get i (env checkpoint) with
+  | Some (I.Element (_, _, pos1, pos2)) ->
+      show text (pos1, pos2)
+  | None -> "???" (* impossible *)
+
+let succeed _v =
+  assert false (* impossible *)
+
+let fail text buffer (checkpoint : _ I.checkpoint) =
+  let location = L.range (E.last buffer) in
+  let err = (E.show (show text) buffer) in 
+  let indication = sprintf "Syntax error %s.\n" err  in
+  try 
+    let message = Errors.message (state checkpoint) in
+    let message = E.expand (get text checkpoint) message in
+    eprintf "%s%s%s" location indication message;
+    exit 1
+  with Not_found ->
+    eprintf "%s%s%s\n" location indication 
+    "Unknown error, more informative error messages coming soon";
+    exit 1
+
+let slow filename text =
+  let lexbuf = L.init filename (Lexing.from_string text) in
+  let supplier = I.lexer_lexbuf_to_supplier Lexer.token lexbuf in
+  let buffer, supplier = E.wrap_supplier supplier in
+  let checkpoint = UnitActionsParser.Incremental.toplevel lexbuf.lex_curr_p in
+  I.loop_handle succeed (fail text buffer) supplier checkpoint
+
+type parse_result = 
+  | Success of directive list * assignment list
+  | Error of string
+
+let fast filename : parse_result =
+  let text, lexbuf =
+     try 
+      L.read filename 
+      with Sys_error s -> prerr_endline ("File error\n" ^ s); exit 1; 
+    in 
+  match P.toplevel Lexer.token lexbuf  with
+  | d, a ->
+    Success (d, a)
+
+  | exception DirectiveError msg -> 
+    eprintf "Directive Error: %s\n" msg; exit 1 
+
+  | exception Lexer.Lexer_error msg ->
+    prerr_endline msg; exit 1
+
+  | exception Parser.Error ->
+    Error text
+
+
+let parse (filename: string) : directive list * assignment list =
+  (* First try fast parser, then use slow parser to generate error if fail *)
+  begin match fast filename with 
+  | Success (d, a) -> (d, a) 
+  | Error s -> slow filename s
+  end

src/parser/parser.mly

@@ -52,6 +52,8 @@ open Compiler.Directive;;
 
 %start toplevel
 
+%on_error_reduce program
+
 %type <directive list * Ast.assignment list> toplevel  
 %type <Ast.bexp> bexp
 %%