Fixed the "end of stream" in the Ligodity parser. Started replacing

new error reporting in ligodity.ml.
This commit is contained in:
Christian Rinderknecht 2019-06-03 17:43:25 +02:00
parent c2643f5b4c
commit 963507ddc0
3 changed files with 53 additions and 13 deletions

View File

@ -94,5 +94,5 @@ let parse_expression (s:string) : AST.expr result =
start.pos_fname s start.pos_fname s
in in
simple_error str simple_error str
) @@ (fun () -> Parser.expr read lexbuf) >>? fun raw -> ) @@ (fun () -> Parser.interactive_expr read lexbuf) >>? fun raw ->
ok raw ok raw

View File

@ -47,9 +47,9 @@ let rec mk_field_path (rank, tail) =
(* Entry points *) (* Entry points *)
%start program expr %start program interactive_expr
%type <AST.t> program %type <AST.t> program
%type <AST.expr> expr %type <AST.expr> interactive_expr
%% %%
@ -382,6 +382,9 @@ tail:
(* Expressions *) (* Expressions *)
interactive_expr:
expr EOF { $1 }
expr: expr:
base_cond__open(expr) { $1 } base_cond__open(expr) { $1 }
| reg(match_expr(base_cond)) { ECase $1 } | reg(match_expr(base_cond)) { ECase $1 }

View File

@ -20,13 +20,48 @@ let get_value : 'a Raw.reg -> 'a = fun x -> x.value
module Errors = struct module Errors = struct
let wrong_pattern expected_name actual = let wrong_pattern expected_name actual =
let title () = "wrong pattern" in let title () = "wrong pattern" in
let message () = Format.asprintf "expected a %s, got something else" expected_name in let message () = "" in
let data = [ let data = [
("expected", fun () -> expected_name);
("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.region_of_pattern actual) ("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.region_of_pattern actual)
] in ] in
error ~data title message error ~data title message
let multiple_patterns construct (patterns: Raw.pattern list) =
let title () = "multiple patterns" in
let message () =
Format.asprintf "multiple patterns in \"%s\" are not supported yet" construct in
let patterns_loc =
List.fold_left (fun a p -> Region.cover a (Raw.region_of_pattern p))
Region.min patterns in
let data = [
("patterns_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc)
] in
error ~data title message
let unknown_predefined_type name =
let title () = "type constants" in
let message () =
Format.asprintf "unknown predefined type \"%s\"" name.Region.value in
let data = [
("typename_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)
] in
error ~data title message
let unsupported_arith_op expr =
let title () = "arithmetic expressions" in
let message () =
Format.asprintf "this arithmetic operator is not supported yet" in
let expr_loc = Raw.region_of_expr expr in
let data = [
("expr_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
] in
error ~data title message
end end
open Errors open Errors
open Operators.Simplify.Ligodity open Operators.Simplify.Ligodity
@ -48,7 +83,7 @@ let rec pattern_to_typed_var : Raw.pattern -> _ = fun p ->
ok (v , Some tp.type_expr) ok (v , Some tp.type_expr)
) )
| Raw.PVar v -> ok (v , None) | Raw.PVar v -> ok (v , None)
| _ -> fail @@ wrong_pattern "var/typed" p | _ -> fail @@ wrong_pattern "typed variable" p
let rec expr_to_typed_expr : Raw.expr -> _ = fun e -> let rec expr_to_typed_expr : Raw.expr -> _ = fun e ->
match e with match e with
@ -59,7 +94,7 @@ let rec expr_to_typed_expr : Raw.expr -> _ = fun e ->
let patterns_to_var : Raw.pattern list -> _ = fun ps -> let patterns_to_var : Raw.pattern list -> _ = fun ps ->
match ps with match ps with
| [ pattern ] -> pattern_to_var pattern | [ pattern ] -> pattern_to_var pattern
| _ -> fail (simple_error "multiple patterns not supported on lets yet") | _ -> fail @@ multiple_patterns "let" ps
let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te ->
trace (simple_info "simplifying this type expression...") @@ trace (simple_info "simplifying this type expression...") @@
@ -83,7 +118,7 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
let (name, tuple) = x.value in let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside in let lst = npseq_to_list tuple.value.inside in
let%bind cst = let%bind cst =
trace_option (simple_error "unrecognized type constants") @@ trace_option (unknown_predefined_type name) @@
List.assoc_opt name.value type_constants List.assoc_opt name.value type_constants
in in
let%bind lst' = bind_map_list simpl_type_expression lst in let%bind lst' = bind_map_list simpl_type_expression lst in
@ -259,7 +294,8 @@ let rec simpl_expression :
let n = Z.to_int @@ snd @@ n in let n = Z.to_int @@ snd @@ n in
return @@ e_literal ~loc (Literal_tez n) return @@ e_literal ~loc (Literal_tez n)
) )
| EArith _ -> simple_fail "arith: not supported yet" | EArith _ as e ->
fail @@ (unsupported_arith_op e)
| EString (String s) -> ( | EString (String s) -> (
let (s , loc) = r_split s in let (s , loc) = r_split s in
let s' = let s' =
@ -268,7 +304,8 @@ let rec simpl_expression :
in in
return @@ e_literal ~loc (Literal_string s') return @@ e_literal ~loc (Literal_string s')
) )
| EString _ -> simple_fail "string: not supported yet" | EString (Cat _) ->
simple_fail "string: not supported yet"
| ELogic l -> simpl_logic_expression l | ELogic l -> simpl_logic_expression l
| EList l -> simpl_list_expression l | EList l -> simpl_list_expression l
| ECase c -> ( | ECase c -> (