Finished upgrading the error reporting for Pascaligo.

2019-06-05 17:51:06 +02:00 · 2019-06-05 17:51:06 +02:00 · 0e01353c7d
commit 0e01353c7d
parent e0228f352c
1 changed files with 217 additions and 41 deletions
--- a/src/simplify/pascaligo.ml
+++ b/src/simplify/pascaligo.ml
@ -15,10 +15,21 @@ let pseq_to_list = function
 let get_value : 'a Raw.reg -> 'a = fun x -> x.value

 module Errors = struct
+  let unsupported_ass_None region =
+    let title () = "assignment of None" in
+    let message () =
+      Format.asprintf "assignments of None are not supported yet" in
+    let data = [
+      ("none_expr",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
+    ] in
+    error ~data title message
+
  let unsupported_entry_decl decl =
    let title () = "entry point declarations" in
    let message () =
-      Format.asprintf "entry points within the contract are not supported yet" in
+      Format.asprintf "entry points within the contract \
+                       are not supported yet" in
    let data = [
      ("declaration",
       fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region)
@ -92,13 +103,176 @@ module Errors = struct
  let unsupported_set_expr expr =
    let title () = "set expressions" in
    let message () =
-      Format.asprintf "set type is not supported yet" in
+      Format.asprintf "the set type is not supported yet" in
     let expr_loc = Raw.expr_to_region expr in
    let data = [
      ("expr_loc",
       fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
    ] in
    error ~data title message
+
+  let unsupported_proc_calls call =
+    let title () = "procedure calls" in
+    let message () =
+      Format.asprintf "procedure calls are not supported yet" in
+    let data = [
+      ("call_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ call.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_for_loops region =
+    let title () = "bounded iterators" in
+    let message () =
+      Format.asprintf "for loops are not supported yet" in
+    let data = [
+      ("loop_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
+    ] in
+    error ~data title message
+
+  let unsupported_deep_map_assign v =
+    let title () = "map assignments" in
+    let message () =
+      Format.asprintf "assignments to embedded maps are not \
+                       supported yet" in
+    let data = [
+      ("lhs_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ v.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_empty_record_patch record_expr =
+    let title () = "empty record patch" in
+    let message () =
+      Format.asprintf "empty record patches are not supported yet" in
+    let data = [
+      ("record_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ record_expr.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_map_patches patch =
+    let title () = "map patches" in
+    let message () =
+      Format.asprintf "map patches (a.k.a. functional updates) are \
+                       not supported yet" in
+    let data = [
+      ("patch_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ patch.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_set_patches patch =
+    let title () = "set patches" in
+    let message () =
+      Format.asprintf "set patches (a.k.a. functional updates) are \
+                       not supported yet" in
+    let data = [
+      ("patch_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ patch.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_deep_map_rm path =
+    let title () = "binding removals" in
+    let message () =
+      Format.asprintf "removal of bindings from embedded maps \
+                       are not supported yet" in
+    let data = [
+      ("path_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ path.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_set_removal remove =
+    let title () = "set removals" in
+    let message () =
+      Format.asprintf "removal of elements in a set is not \
+                       supported yet" in
+    let data = [
+      ("removal_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ remove.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_non_var_pattern p =
+    let title () = "pattern is not a variable" in
+    let message () =
+      Format.asprintf "non-variable patterns in constructors \
+                       are not supported yet" in
+    let pattern_loc = Raw.pattern_to_region p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let only_constructors p =
+    let title () = "constructors in patterns" in
+    let message () =
+      Format.asprintf "currently, only constructors are supported in patterns" in
+    let pattern_loc = Raw.pattern_to_region p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_tuple_pattern p =
+    let title () = "tuple pattern" in
+    let message () =
+      Format.asprintf "tuple patterns are not supported yet" in
+    let pattern_loc = Raw.pattern_to_region p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_deep_Some_patterns pattern =
+    let title () = "option patterns" in
+    let message () =
+      Format.asprintf "currently, only variables in Some constructors \
+                       in patterns are supported" in
+    let pattern_loc = Raw.pattern_to_region pattern in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_deep_list_patterns cons =
+    let title () = "lists in patterns" in
+    let message () =
+      Format.asprintf "currently, only empty lists and x::y \
+                       are supported in patterns" in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ cons.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_sub_blocks b =
+    let title () = "block instructions" in
+    let message () =
+      Format.asprintf "Sub-blocks are not supported yet" in
+    let data = [
+      ("block_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ b.Region.region)
+    ] in
+    error ~data title message
+
+  (* Logging *)
+
+  let simplifying_instruction t =
+    let title () = "simplifiying instruction" in
+    let message () = "" in
+    let data = [
+      ("instruction",
+       fun () -> Format.asprintf "%a" PP_helpers.(printer Parser.Pascaligo.ParserLog.print_instruction) t)
+    ] in
+    error ~data title message
 end

 open Errors
@ -542,7 +716,8 @@ and simpl_statement : Raw.statement -> (_ -> expression result) result =
 and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result =
  fun t ->
  match t with
-  | ProcCall _ -> simple_fail "no proc call"
+  | ProcCall call ->
+      fail @@ unsupported_proc_calls call
  | Fail e -> (
      let%bind expr = simpl_expression e.value.fail_expr in
      return @@ e_failwith expr
@ -557,8 +732,8 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
      let%bind body = simpl_block l.block.value in
      let%bind body = body None in
      return @@ e_loop cond body
-  | Loop (For _) ->
-      simple_fail "no for yet"
+  | Loop (For (ForInt {region; _} | ForCollect {region; _})) ->
+      fail @@ unsupported_for_loops region
  | Cond c -> (
      let (c , loc) = r_split c in
      let%bind expr = simpl_expression c.test in
@ -576,7 +751,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
      let (a , loc) = r_split a in
      let%bind value_expr = match a.rhs with
        | Expr e -> simpl_expression e
-        | NoneExpr _ -> simple_fail "no none assignments yet"
+        | NoneExpr reg -> fail @@ unsupported_ass_None reg
      in
      match a.lhs with
        | Path path -> (
@ -587,7 +762,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
            let v' = v.value in
            let%bind name = match v'.path with
              | Name name -> ok name
-              | _ -> simple_fail "no complex map assignments yet" in
+              | _ -> fail @@ unsupported_deep_map_assign v in
            let%bind key_expr = simpl_expression v'.index.value.inside in
            let old_expr = e_variable name.value in
            let expr' = e_map_update key_expr value_expr old_expr in
@ -614,7 +789,8 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
      let%bind inj = bind_list
        @@ List.map (fun (x:Raw.field_assign Region.reg) ->
            let (x , loc) = r_split x in
-            let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e , loc)
+            let%bind e = simpl_expression x.field_expr
+            in ok (x.field_name.value, e , loc)
          )
        @@ pseq_to_list r.record_inj.value.elements in
      let%bind expr =
@ -622,27 +798,30 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
          e_assign ~loc name (access_path @ [ Access_record access ]) v in
        let assigns = List.map aux inj in
        match assigns with
-        | [] -> simple_fail "empty record patch"
+               (* E_sequence (E_skip, E_skip) ? *)
+        | [] -> fail @@ unsupported_empty_record_patch r.record_inj
        | hd :: tl -> (
-            let aux acc cur = e_sequence (acc) (cur) in
+            let aux acc cur = e_sequence acc cur in
            ok @@ List.fold_left aux hd tl
          )
      in
      return @@ expr
    )
-  | MapPatch _ -> simple_fail "no map patch yet"
-  | SetPatch _ -> simple_fail "no set patch yet"
+  | MapPatch patch ->
+      fail @@ unsupported_map_patches patch
+  | SetPatch patch ->
+      fail @@ unsupported_set_patches patch
  | MapRemove r -> (
      let (v , loc) = r_split r in
      let key = v.key in
      let%bind map = match v.map with
        | Name v -> ok v.value
-        | _ -> simple_fail "no complex map remove yet" in
+        | Path path -> fail @@ unsupported_deep_map_rm path in
      let%bind key' = simpl_expression key in
      let expr = e_constant ~loc "MAP_REMOVE" [key' ; e_variable map] in
      return @@ e_assign ~loc map [] expr
    )
-  | SetRemove _ -> simple_fail "no set remove yet"
+  | SetRemove r -> fail @@ unsupported_set_removal r

 and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
  match p with
@ -663,15 +842,10 @@ and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->

 and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
  let open Raw in
-  let get_var (t:Raw.pattern) = match t with
+  let get_var (t:Raw.pattern) =
+    match t with
    | PVar v -> ok v.value
-    | _ ->
-        let error =
-          let title () = "not a var" in
-          let content () = Format.asprintf "%a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) t in
-          error title content
-        in
-        fail error
+    | p -> fail @@ unsupported_non_var_pattern p
  in
  let get_tuple (t:Raw.pattern) = match t with
    | PCons v -> npseq_to_list v.value
@ -681,32 +855,33 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
  let get_single (t:Raw.pattern) =
    let t' = get_tuple t in
    let%bind () =
-      trace_strong (simple_error "not single") @@
+      trace_strong (unsupported_tuple_pattern t) @@
      Assert.assert_list_size t' 1 in
    ok (List.hd t') in
  let get_constr (t:Raw.pattern) = match t with
    | PConstr v ->
        let%bind var = get_single (snd v.value).value >>? get_var in
        ok ((fst v.value).value , var)
-    | _ -> simple_fail "not a constr"
+    | _ -> fail @@ only_constructors t
  in
  let%bind patterns =
    let aux (x , y) =
      let xs = get_tuple x in
-      trace_strong (simple_error "no tuple in patterns yet") @@
+      trace_strong (unsupported_tuple_pattern x) @@
      Assert.assert_list_size xs 1 >>? fun () ->
      ok (List.hd xs , y)
    in
    bind_map_list aux t in
  match patterns with
  | [(PFalse _ , f) ; (PTrue _ , t)]
-  | [(PTrue _ , t) ; (PFalse _ , f)] -> ok @@ Match_bool {match_true = t ; match_false = f}
+  | [(PTrue _ , t) ; (PFalse _ , f)] ->
+      ok @@ Match_bool {match_true = t ; match_false = f}
  | [(PSome v , some) ; (PNone _ , none)]
  | [(PNone _ , none) ; (PSome v , some)] -> (
      let (_, v) = v.value in
      let%bind v = match v.value.inside with
        | PVar v -> ok v.value
-        | _ -> simple_fail "complex none patterns not supported yet" in
+        | p -> fail @@ unsupported_deep_Some_patterns p in
      ok @@ Match_option {match_none = none ; match_some = (v, some) }
    )
  | [(PCons c , cons) ; (PList (PNil _) , nil)]
@ -717,11 +892,12 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
            let%bind a = get_var a in
            let%bind b = get_var b in
            ok (a, b)
-        | _ -> simple_fail "complex list patterns not supported yet"
+        | _ -> fail @@ unsupported_deep_list_patterns c
      in
      ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
  | lst ->
-      trace (simple_error "weird patterns not supported yet") @@
+      trace (simple_info "currently, only booleans, options, lists and \
+                         user-defined constructors are supported in patterns") @@
      let%bind constrs =
        let aux (x , y) =
          let error =
@ -736,27 +912,27 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
        bind_map_list aux lst in
      ok @@ Match_variant constrs

-and simpl_instruction_block : Raw.instruction -> (_ -> expression result) result = fun t ->
+and simpl_instruction_block : Raw.instruction -> (_ -> expression result) result =
+  fun t ->
  match t with
  | Single s -> simpl_single_instruction s
  | Block b -> simpl_block b.value

-and simpl_instruction : Raw.instruction -> (_ -> expression result) result = fun t ->
-  let main_error =
-    let title () = "simplifiying instruction" in
-    let content () = Format.asprintf "%a" PP_helpers.(printer Parser.Pascaligo.ParserLog.print_instruction) t in
-    error title content in
-  trace main_error @@
+and simpl_instruction : Raw.instruction -> (_ -> expression result) result =
+  fun t ->
+  trace (simplifying_instruction t) @@
  match t with
  | Single s -> simpl_single_instruction s
-  | Block _ -> simple_fail "no block instruction yet"
+  | Block b -> fail @@ unsupported_sub_blocks b

-and simpl_statements : Raw.statements -> (_ -> expression result) result = fun ss ->
+and simpl_statements : Raw.statements -> (_ -> expression result) result =
+  fun ss ->
  let lst = npseq_to_list ss in
  let%bind fs = bind_map_list simpl_statement lst in
-  let aux : _ -> (expression option -> expression result) -> _ = fun prec cur ->
-    let%bind res = cur prec in
-    ok @@ Some res in
+  let aux : _ -> (expression option -> expression result) -> _ =
+    fun prec cur ->
+      let%bind res = cur prec in
+      ok @@ Some res in
  ok @@ fun (expr' : _ option) ->
  let%bind ret = bind_fold_right_list aux expr' fs in
  ok @@ Option.unopt_exn ret