From 4f60f2376905523ce3544836d1603f3de55272f8 Mon Sep 17 00:00:00 2001
From: Christian Rinderknecht <Christian.Rinderknecht@tezcore.com>
Date: Tue, 4 Jun 2019 13:45:21 +0200
Subject: [PATCH 1/3] Finished changing the error reporting.

---
 src/simplify/ligodity.ml | 92 ++++++++++++++++++++++++++++------------
 1 file changed, 66 insertions(+), 26 deletions(-)

diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml
index d2b5a3cc2..61831f5d5 100644
--- a/src/simplify/ligodity.ml
+++ b/src/simplify/ligodity.ml
@@ -104,6 +104,48 @@ module Errors = struct
     ] 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.region_of_pattern p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let simplifying_expr t =
+    let title () = "simplifying expression" in
+    let message () = "" in
+    let data = [
+      ("expression" ,
+       thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t)
+    ] 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.region_of_pattern p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_sugared_lists region =
+    let title () = "lists in patterns" in
+    let message () =
+      Format.asprintf "currently, only empty lists and constructors (::) \
+                       are supported in patterns" in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
+    ] in
+    error ~data title message
 end
 
 open Errors
@@ -173,10 +215,12 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
       ok tpl
   | TRecord r ->
       let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in
+      let apply (x:Raw.field_decl Raw.reg) =
+        (x.value.field_name.value, x.value.field_type) in
       let%bind lst =
         bind_list
         @@ List.map aux
-        @@ List.map (fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type))
+        @@ List.map apply
         @@ pseq_to_list r.value.elements in
       let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
       ok @@ T_record m
@@ -226,14 +270,7 @@ let rec simpl_expression :
     return @@ e_accessor ~loc var path'
   in
 
-  trace (
-    let title () = "simplifying expression" in
-    let message () = "" in
-    let data = [
-      ("expression" , thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t)
-    ] in
-    error ~data title message
-  ) @@
+  trace (simplifying_expr t) @@
   match t with
   | Raw.ELetIn e -> (
       let Raw.{binding ; body ; _} = e.value in
@@ -555,19 +592,17 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
         )
     )
 
-and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
+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 rec 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 Raw.print_pattern) t in
-          error title content
-        in
-        fail error
+    | PPar p -> get_var p.value.inside
+    | _ -> fail @@ unsupported_non_var_pattern t
   in
-  let rec get_tuple (t:Raw.pattern) = match t with
+  let rec get_tuple (t:Raw.pattern) =
+    match t with
     | PTuple v -> npseq_to_list v.value
     | PPar p -> get_tuple p.value.inside
     | x -> [ x ]
@@ -577,8 +612,11 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
     let%bind () =
       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
+    ok (List.hd t')
+  in
+  let rec get_constr (t:Raw.pattern) =
+    match t with
+    | PPar p -> get_constr p.value.inside
     | PConstr v -> (
         let (const , pat_opt) = v.value in
         let%bind pat =
@@ -588,23 +626,24 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
         let%bind var = get_var single_pat in
         ok (const.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}
   | [(PList (PCons c) , cons) ; (PList (Sugar sugar_nil) , nil)]
   | [(PList (Sugar sugar_nil) , nil) ; (PList (PCons c),  cons)] -> (
       let%bind () =
-        trace_strong (simple_error "Only empty list patterns and cons are allowed yet")
+        trace_strong (unsupported_sugared_lists sugar_nil.region)
         @@ Assert.assert_list_empty
         @@ pseq_to_list
         @@ sugar_nil.value.elements in
@@ -617,7 +656,8 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
       ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
     )
   | lst -> (
-      trace (simple_info "weird patterns not supported yet") @@
+      trace (simple_info "currently, only booleans, lists and constructors \
+                          are supported in patterns") @@
       let%bind constrs =
         let aux (x , y) =
           let error =

From 22f930b53131477512d88b47ea38abffc24704dc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@nomadic-labs.com>
Date: Tue, 4 Jun 2019 14:24:24 +0200
Subject: [PATCH 2/3] locations in error messages in typer.ml where possible

---
 src/typer/typer.ml | 172 +++++++++++++++++++++++++++------------------
 1 file changed, 102 insertions(+), 70 deletions(-)

diff --git a/src/typer/typer.ml b/src/typer/typer.ml
index 4104db3df..1779837ce 100644
--- a/src/typer/typer.ml
+++ b/src/typer/typer.ml
@@ -16,106 +16,123 @@ module Errors = struct
     let message () = "" in
     let data = [
       ("variable" , fun () -> Format.asprintf "%s" n) ;
+      (* TODO: types don't have srclocs for now. *)
+      (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
       ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
     ] in
     error ~data title message ()
 
-  let unbound_variable (e:environment) (n:string) () =
+  let unbound_variable (e:environment) (n:string) (loc:Location.t) () =
     let title = (thunk "unbound variable") in
     let message () = "" in
     let data = [
       ("variable" , fun () -> Format.asprintf "%s" n) ;
-      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
+      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let match_empty_variant : type a . a I.matching -> unit -> _ =
-    fun matching () ->
+  let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ =
+    fun matching loc () ->
     let title = (thunk "match with no cases") in
     let message () = "" in
     let data = [
-      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching)
+      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let match_missing_case : type a . a I.matching -> unit -> _ =
-    fun matching () ->
+  let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ =
+    fun matching loc () ->
     let title = (thunk "missing case in match") in
     let message () = "" in
     let data = [
-      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching)
+      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let match_redundant_case : type a . a I.matching -> unit -> _ =
-    fun matching () ->
+  let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ =
+    fun matching loc () ->
     let title = (thunk "missing case in match") in
     let message () = "" in
     let data = [
-      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching)
+      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let unbound_constructor (e:environment) (n:string) () =
+  let unbound_constructor (e:environment) (n:string) (loc:Location.t) () =
     let title = (thunk "unbound constructor") in
     let message () = "" in
     let data = [
       ("constructor" , fun () -> Format.asprintf "%s" n) ;
-      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
+      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let unrecognized_constant (n:string) () =
+  let unrecognized_constant (n:string) (loc:Location.t) () =
     let title = (thunk "unrecognized constant") in
     let message () = "" in
     let data = [
       ("constant" , fun () -> Format.asprintf "%s" n) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let wrong_arity (n:string) (expected:int) (actual:int) () =
+  let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
     let title () = "wrong arity" in
     let message () = "" in
     let data = [
       ("function" , fun () -> Format.asprintf "%s" n) ;
       ("expected" , fun () -> Format.asprintf "%d" expected) ;
-      ("actual" , fun () -> Format.asprintf "%d" actual)
+      ("actual" , fun () -> Format.asprintf "%d" actual) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let match_tuple_wrong_arity (expected:'a list) (actual:'b list) () =
+  let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
     let title () = "matching tuple of different size" in
     let message () = "" in
     let data = [
       ("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ;
-      ("actual" , fun () -> Format.asprintf "%d" (List.length actual))
+      ("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
+  (* TODO: this should be a trace_info? *)
   let program_error (p:I.program) () =
     let message () = "" in
     let title = (thunk "typing program") in
     let data = [
-      "program" , fun () -> Format.asprintf "%a" I.PP.program p
+      ("program" , fun () -> Format.asprintf "%a" I.PP.program p)
     ] in
     error ~data title message ()
 
-  let constant_declaration_error (name:string) (ae:I.expr) () =
+  let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_value option) () =
     let title = (thunk "typing constant declaration") in
     let message () = "" in
     let data = [
       ("constant" , fun () -> Format.asprintf "%s" name) ;
-      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae)
+      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
+      ("expected" , fun () ->
+          match expected with
+            None -> "(no annotation for the expected type)"
+          | Some expected -> Format.asprintf "%a" O.PP.type_value expected) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
     ] in
     error ~data title message ()
 
-  let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> unit -> _ =
-    fun ?(msg = "") ~expected ~actual () ->
+  let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
+    fun ?(msg = "") ~expected ~actual loc () ->
     let title = (thunk "typing match") in
     let message () = msg in
     let data = [
       ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
-      ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual)
+      ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
@@ -123,47 +140,52 @@ module Errors = struct
     let title = (thunk "this expression must be annotated with its type") in
     let message () = Format.asprintf "%s needs an annotation" case in
     let data = [
-      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e)
+      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
     ] in
     error ~data title message ()
 
-  let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : O.value) () =
+  let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () =
     let title = (thunk "type error") in
     let message () = msg in
     let data = [
       ("expected"   , fun () -> Format.asprintf "%s" expected);
       ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_value actual);
-      ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression)
+      ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : O.value) () =
+  let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () =
     let title = (thunk "type error") in
     let message () = msg in
     let data = [
       ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_value expected);
       ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_value actual);
-      ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression)
+      ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) () =
+  let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
     let title = (thunk "invalid tuple index") in
     let message () = "" in
     let data = [
       ("index" , fun () -> Format.asprintf "%d" index) ;
       ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t)
+      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) () =
+  let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
     let title = (thunk "invalid record field") in
     let message () = "" in
     let data = [
       ("field" , fun () -> Format.asprintf "%s" field) ;
       ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t)
+      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
@@ -171,7 +193,8 @@ module Errors = struct
     let title = (thunk "not suported yet") in
     let message () = message in
     let data = [
-      ("expression" , fun () -> Format.asprintf "%a"  I.PP.expression ae)
+      ("expression" , fun () -> Format.asprintf "%a"  I.PP.expression ae) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
     ] in
     error ~data title message ()
 
@@ -208,24 +231,24 @@ and type_declaration env : I.declaration -> (environment * O.declaration option)
   | Declaration_constant (name , tv_opt , expression) -> (
       let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
       let%bind ae' =
-        trace (constant_declaration_error name expression) @@
+        trace (constant_declaration_error name expression tv'_opt) @@
         type_expression ?tv_opt:tv'_opt env expression in
       let env' = Environment.add_ez_ae name ae' env in
       ok (env', Some (O.Declaration_constant ((make_n_e name ae') , (env , env'))))
     )
 
-and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> o O.matching result =
-  fun f e t i -> match i with
+and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> Location.t -> o O.matching result =
+  fun f e t i loc -> match i with
     | Match_bool {match_true ; match_false} ->
       let%bind _ =
-        trace_strong (match_error ~expected:i ~actual:t)
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_bool t in
       let%bind match_true = f e match_true in
       let%bind match_false = f e match_false in
       ok (O.Match_bool {match_true ; match_false})
   | Match_option {match_none ; match_some} ->
       let%bind t_opt =
-        trace_strong (match_error ~expected:i ~actual:t)
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_option t in
       let%bind match_none = f e match_none in
       let (n, b) = match_some in
@@ -235,7 +258,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       ok (O.Match_option {match_none ; match_some = (n', b')})
   | Match_list {match_nil ; match_cons} ->
       let%bind t_list =
-        trace_strong (match_error ~expected:i ~actual:t)
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_list t in
       let%bind match_nil = f e match_nil in
       let (hd, tl, b) = match_cons in
@@ -245,10 +268,10 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')})
   | Match_tuple (lst, b) ->
       let%bind t_tuple =
-        trace_strong (match_error ~expected:i ~actual:t)
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_tuple t in
       let%bind lst' =
-        generic_try (match_tuple_wrong_arity t_tuple lst)
+        generic_try (match_tuple_wrong_arity t_tuple lst loc)
         @@ (fun () -> List.combine lst t_tuple) in
       let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
       let e' = List.fold_left aux e lst' in
@@ -258,7 +281,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       let%bind variant_opt =
         let aux acc ((constructor_name , _) , _) =
           let%bind (_ , variant) =
-            trace_option (unbound_constructor e constructor_name) @@
+            trace_option (unbound_constructor e constructor_name loc) @@
             Environment.get_constructor constructor_name e in
           let%bind acc = match acc with
             | None -> ok (Some variant)
@@ -270,11 +293,11 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
         trace (simple_info "in match variant") @@
         bind_fold_list aux None lst in
       let%bind variant =
-        trace_option (match_empty_variant i) @@
+        trace_option (match_empty_variant i loc) @@
         variant_opt in
       let%bind () =
         let%bind variant_cases' =
-          trace (match_error ~expected:i ~actual:t)
+          trace (match_error ~expected:i ~actual:t loc)
           @@ Ast_typed.Combinators.get_t_sum variant in
         let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in
         let match_cases = List.map (Function.compose fst fst) lst in
@@ -282,17 +305,17 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
           Assert.assert_true (List.mem c match_cases)
         in
         let%bind () =
-          trace_strong (match_missing_case i) @@
+          trace_strong (match_missing_case i loc) @@
           bind_iter_list test_case variant_cases in
         let%bind () =
-          trace_strong (match_redundant_case i) @@
+          trace_strong (match_redundant_case i loc) @@
           Assert.assert_true List.(length variant_cases = length match_cases) in
         ok ()
       in
       let%bind lst' =
         let aux ((constructor_name , name) , b) =
           let%bind (constructor , _) =
-            trace_option (unbound_constructor e constructor_name) @@
+            trace_option (unbound_constructor e constructor_name loc) @@
             Environment.get_constructor constructor_name e in
           let e' = Environment.add_ez_binder name constructor e in
           let%bind b' = f e' b in
@@ -361,7 +384,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
   | E_failwith _ -> fail @@ needs_annotation ae "the failwith keyword"
   | E_variable name ->
       let%bind tv' =
-        trace_option (unbound_variable e name)
+        trace_option (unbound_variable e name ae.location)
         @@ Environment.get_opt name e in
       return (E_variable name) tv'.type_value
   | E_literal (Literal_bool b) ->
@@ -391,30 +414,30 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
       let%bind lst' = bind_list @@ List.map (type_expression e) lst in
       let tv_lst = List.map get_type_annotation lst' in
       return (E_tuple lst') (t_tuple tv_lst ())
-  | E_accessor (ae, path) ->
-      let%bind e' = type_expression e ae in
+  | E_accessor (ae', path) ->
+      let%bind e' = type_expression e ae' in
       let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result =
         match a with
         | Access_tuple index -> (
             let%bind tpl_tv = get_t_tuple prev.type_annotation in
             let%bind tv =
-              generic_try (bad_tuple_index index ae prev.type_annotation)
+              generic_try (bad_tuple_index index ae' prev.type_annotation ae.location)
               @@ (fun () -> List.nth tpl_tv index) in
             return (E_tuple_accessor (prev , index)) tv
           )
         | Access_record property -> (
             let%bind r_tv = get_t_record prev.type_annotation in
             let%bind tv =
-              generic_try (bad_record_access property ae prev.type_annotation)
+              generic_try (bad_record_access property ae' prev.type_annotation ae.location)
               @@ (fun () -> SMap.find property r_tv) in
             return (E_record_accessor (prev , property)) tv
           )
-        | Access_map ae -> (
-            let%bind ae' = type_expression e ae in
+        | Access_map ae' -> (
+            let%bind ae'' = type_expression e ae' in
             let%bind (k , v) = get_t_map prev.type_annotation in
             let%bind () =
-              Ast_typed.assert_type_value_eq (k , get_type_annotation ae') in
-            return (E_look_up (prev , ae')) v
+              Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in
+            return (E_look_up (prev , ae'')) v
           )
       in
       trace (simple_info "accessing") @@
@@ -533,7 +556,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
   | E_constant (name, lst) ->
       let%bind lst' = bind_list @@ List.map (type_expression e) lst in
       let tv_lst = List.map get_type_annotation lst' in
-      let%bind (name', tv) = type_constant name tv_lst tv_opt in
+      let%bind (name', tv) = type_constant name tv_lst tv_opt ae.location in
       return (E_constant (name' , lst')) tv
   | E_application (f, arg) ->
       let%bind f = type_expression e f in
@@ -547,6 +570,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
             ~expected:"should be a function type"
             ~expression:f
             ~actual:f.type_annotation
+            f.location
       in
       return (E_application (f , arg)) tv
   | E_look_up dsi ->
@@ -565,10 +589,14 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
           let%bind mf' = type_expression e match_false in
           let t = get_type_annotation ex' in
           let%bind () =
-            trace_strong (match_error ~expected:m ~actual:t)
+            trace_strong (match_error ~expected:m ~actual:t ae.location)
             @@ assert_t_bool t in
           let%bind () =
-            trace_strong (match_error ~msg:"matching not-unit on an assert" ~expected:m ~actual:t)
+            trace_strong (match_error
+                            ~msg:"matching not-unit on an assert"
+                            ~expected:m
+                            ~actual:t
+                            ae.location)
             @@ assert_t_unit (get_type_annotation mf') in
           let mt' = make_a_e
               (E_constant ("ASSERT" , [ex' ; fw']))
@@ -579,7 +607,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
           return (O.E_matching (ex' , m')) (t_unit ())
         )
       | _ -> (
-          let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m in
+          let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae.location in
           let tvs =
             let aux (cur:O.value O.matching) =
               match cur with
@@ -597,7 +625,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
             ok (Some cur) in
           let%bind tv_opt = bind_fold_list aux None tvs in
           let%bind tv =
-            trace_option (match_empty_variant m) @@
+            trace_option (match_empty_variant m ae.location) @@
             tv_opt in
           return (O.E_matching (ex', m')) tv
         )
@@ -611,7 +639,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
                       ~msg:"first part of the sequence should be of unit type"
                       ~expected:(O.t_unit ())
                       ~actual:a'_type_annot
-                      ~expression:a') @@
+                      ~expression:a'
+                      a'.location) @@
       Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in
     return (O.E_sequence (a' , b')) (get_type_annotation b')
   | E_loop (expr , body) ->
@@ -623,7 +652,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
                       ~msg:"while condition isn't of type bool"
                       ~expected:(O.t_bool ())
                       ~actual:t_expr'
-                      ~expression:expr') @@
+                      ~expression:expr'
+                      expr'.location) @@
       Ast_typed.assert_type_value_eq (t_bool () , t_expr') in
     let t_body' = get_type_annotation body' in
     let%bind () =
@@ -631,7 +661,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
                      ~msg:"while body isn't of unit type"
                      ~expected:(O.t_unit ())
                      ~actual:t_body'
-                     ~expression:body') @@
+                     ~expression:body'
+                     body'.location) @@
       Ast_typed.assert_type_value_eq (t_unit () , t_body') in
     return (O.E_loop (expr' , body')) (t_unit ())
   | E_assign (name , path , expr) ->
@@ -644,14 +675,14 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
         | Access_tuple index -> (
             let%bind tpl = get_t_tuple prec_tv in
             let%bind tv' =
-              trace_option (bad_tuple_index index ae prec_tv) @@
+              trace_option (bad_tuple_index index ae prec_tv ae.location) @@
               List.nth_opt tpl index in
             ok (tv' , prec_path @ [O.Access_tuple index])
           )
         | Access_record property -> (
             let%bind m = get_t_record prec_tv in
             let%bind tv' =
-              trace_option (bad_record_access property ae prec_tv) @@
+              trace_option (bad_record_access property ae prec_tv ae.location) @@
               Map.String.find_opt property m in
             ok (tv' , prec_path @ [O.Access_record property])
           )
@@ -666,7 +697,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
                      ~msg:"type of the expression to assign doesn't match left-hand-side"
                      ~expected:assign_tv
                      ~actual:t_expr'
-                     ~expression:expr') @@
+                     ~expression:expr'
+                     expr'.location) @@
       Ast_typed.assert_type_value_eq (assign_tv , t_expr') in
     return (O.E_assign (typed_name , path' , expr')) (t_unit ())
   | E_let_in {binder ; rhs ; result} ->
@@ -682,11 +714,11 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
     ok {expr' with type_annotation}
 
 
-and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result =
+and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result =
   (* Constant poorman's polymorphism *)
   let ct = Operators.Typer.constant_typers in
   let%bind typer =
-    trace_option (unrecognized_constant name) @@
+    trace_option (unrecognized_constant name loc) @@
     Map.String.find_opt name ct in
   typer lst tv_opt
 

From 97dd2db4b84f18869b4d4c6c66eb3a67f42c90f2 Mon Sep 17 00:00:00 2001
From: Christian Rinderknecht <Christian.Rinderknecht@tezcore.com>
Date: Tue, 4 Jun 2019 16:12:17 +0200
Subject: [PATCH 3/3] I forbade local entry points in Pascaligo (meaningless).

I refactored the projections in Ligodity (AST), so they have the
same name and types as in Pascaligo, which will ease the creation
of module CommonErrors in a file.
---
 src/parser/ligodity/AST.ml        |  35 ++++---
 src/parser/ligodity/AST.mli       |   6 +-
 src/parser/pascaligo/AST.ml       |  10 +-
 src/parser/pascaligo/AST.mli      |   5 +-
 src/parser/pascaligo/Parser.mly   |   5 +-
 src/parser/pascaligo/ParserLog.ml |   3 +-
 src/simplify/ligodity.ml          |  32 ++++--
 src/simplify/pascaligo.ml         | 164 ++++++++++++++++++++++++------
 8 files changed, 186 insertions(+), 74 deletions(-)

diff --git a/src/parser/ligodity/AST.ml b/src/parser/ligodity/AST.ml
index 9d3be1095..aecb8c277 100644
--- a/src/parser/ligodity/AST.ml
+++ b/src/parser/ligodity/AST.ml
@@ -346,7 +346,7 @@ and conditional = {
 
 let sprintf = Printf.sprintf
 
-let region_of_type_expr = function
+let type_expr_to_region = function
   TProd {region; _}
 | TSum {region; _}
 | TRecord {region; _}
@@ -355,12 +355,11 @@ let region_of_type_expr = function
 | TPar {region; _}
 | TAlias {region; _} -> region
 
-
-let region_of_list_pattern = function
+let list_pattern_to_region = function
   Sugar {region; _} | PCons {region; _} -> region
 
-let region_of_pattern = function
-  PList p -> region_of_list_pattern p
+let pattern_to_region = function
+  PList p -> list_pattern_to_region p
 | PTuple {region;_} | PVar {region;_}
 | PUnit {region;_} | PInt {region;_}
 | PTrue region | PFalse region
@@ -368,38 +367,38 @@ let region_of_pattern = function
 | PConstr {region; _} | PPar {region;_}
 | PRecord {region; _} | PTyped {region; _} -> region
 
-let region_of_bool_expr = function
+let bool_expr_to_region = function
   Or {region;_} | And {region;_}
 | True region | False region
 | Not {region;_} -> region
 
-let region_of_comp_expr = function
+let comp_expr_to_region = function
   Lt {region;_} | Leq {region;_}
 | Gt {region;_} | Geq {region;_}
 | Neq {region;_} | Equal {region;_} -> region
 
-let region_of_logic_expr = function
-  BoolExpr e -> region_of_bool_expr e
-| CompExpr e -> region_of_comp_expr e
+let logic_expr_to_region = function
+  BoolExpr e -> bool_expr_to_region e
+| CompExpr e -> comp_expr_to_region e
 
-let region_of_arith_expr = function
+let arith_expr_to_region = function
   Add {region;_} | Sub {region;_} | Mult {region;_}
 | Div {region;_} | Mod {region;_} | Neg {region;_}
 | Int {region;_} | Mtz {region; _}
 | Nat {region; _} -> region
 
-let region_of_string_expr = function
+let string_expr_to_region = function
   String {region;_} | Cat {region;_} -> region
 
-let region_of_list_expr = function
+let list_expr_to_region = function
   Cons {region; _} | List {region; _}
 (* | Append {region; _}*) -> region
 
-let region_of_expr = function
-  ELogic e -> region_of_logic_expr e
-| EArith e -> region_of_arith_expr e
-| EString e -> region_of_string_expr e
-| EList e -> region_of_list_expr e
+let expr_to_region = function
+  ELogic e -> logic_expr_to_region e
+| EArith e -> arith_expr_to_region e
+| EString e -> string_expr_to_region e
+| EList e -> list_expr_to_region e
 | EAnnot {region;_ } | ELetIn {region;_} | EFun {region;_}
 | ECond {region;_} | ETuple {region;_} | ECase {region;_}
 | ECall {region;_} | EVar {region; _} | EProj {region; _}
diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli
index fbad9289e..f782ebd10 100644
--- a/src/parser/ligodity/AST.mli
+++ b/src/parser/ligodity/AST.mli
@@ -470,9 +470,9 @@ val print_tokens : (*?undo:bool ->*) ast -> unit
 (* Projecting regions from sundry nodes of the AST. See the first
    comment at the beginning of this file. *)
 
-val region_of_pattern   : pattern -> Region.t
-val region_of_expr      : expr -> Region.t
-val region_of_type_expr : type_expr -> Region.t
+val pattern_to_region   : pattern -> Region.t
+val expr_to_region      : expr -> Region.t
+val type_expr_to_region : type_expr -> Region.t
 
 (* Simplifications *)
 
diff --git a/src/parser/pascaligo/AST.ml b/src/parser/pascaligo/AST.ml
index 84930a580..14557beda 100644
--- a/src/parser/pascaligo/AST.ml
+++ b/src/parser/pascaligo/AST.ml
@@ -315,8 +315,9 @@ and statement =
 | Data  of data_decl
 
 and local_decl =
-  LocalLam   of lambda_decl
-| LocalData  of data_decl
+  LocalFun  of fun_decl reg
+| LocalProc of proc_decl reg
+| LocalData of data_decl
 
 and data_decl =
   LocalConst of const_decl reg
@@ -785,9 +786,8 @@ let pattern_to_region = function
 | PTuple      {region; _} -> region
 
 let local_decl_to_region = function
-  LocalLam FunDecl     {region; _}
-| LocalLam ProcDecl    {region; _}
-| LocalLam EntryDecl   {region; _}
+  LocalFun             {region; _}
+| LocalProc            {region; _}
 | LocalData LocalConst {region; _}
 | LocalData LocalVar   {region; _} -> region
 
diff --git a/src/parser/pascaligo/AST.mli b/src/parser/pascaligo/AST.mli
index 7de078bea..ccb9b7712 100644
--- a/src/parser/pascaligo/AST.mli
+++ b/src/parser/pascaligo/AST.mli
@@ -299,8 +299,9 @@ and statement =
 | Data  of data_decl
 
 and local_decl =
-  LocalLam   of lambda_decl
-| LocalData  of data_decl
+  LocalFun  of fun_decl reg
+| LocalProc of proc_decl reg
+| LocalData of data_decl
 
 and data_decl =
   LocalConst of const_decl reg
diff --git a/src/parser/pascaligo/Parser.mly b/src/parser/pascaligo/Parser.mly
index 940825a13..9c68a6e09 100644
--- a/src/parser/pascaligo/Parser.mly
+++ b/src/parser/pascaligo/Parser.mly
@@ -426,8 +426,9 @@ open_var_decl:
     in {region; value}}
 
 local_decl:
-  lambda_decl { LocalLam  $1 }
-| data_decl   { LocalData $1 }
+  fun_decl  { LocalFun  $1 }
+| proc_decl { LocalProc $1 }
+| data_decl { LocalData $1 }
 
 data_decl:
   const_decl { LocalConst $1 }
diff --git a/src/parser/pascaligo/ParserLog.ml b/src/parser/pascaligo/ParserLog.ml
index 61dcc9f2f..671e9d916 100644
--- a/src/parser/pascaligo/ParserLog.ml
+++ b/src/parser/pascaligo/ParserLog.ml
@@ -251,7 +251,8 @@ and print_local_decls sequence =
   List.iter print_local_decl sequence
 
 and print_local_decl = function
-  LocalLam  decl -> print_lambda_decl decl
+  LocalFun  decl -> print_fun_decl  decl
+| LocalProc decl -> print_proc_decl decl
 | LocalData decl -> print_data_decl decl
 
 and print_data_decl = function
diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml
index eb4caebcd..e938ad285 100644
--- a/src/simplify/ligodity.ml
+++ b/src/simplify/ligodity.ml
@@ -23,7 +23,7 @@ module Errors = struct
     let message () = "" in
     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.pattern_to_region actual)
     ] in
     error ~data title message
 
@@ -32,7 +32,7 @@ module Errors = struct
     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))
+      List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p))
         Region.min patterns in
     let data = [
       ("patterns_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc)
@@ -53,7 +53,7 @@ module Errors = struct
     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 expr_loc = Raw.expr_to_region expr in
     let data = [
       ("expr_loc",
        fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
@@ -64,7 +64,7 @@ module Errors = struct
     let title () = "string expressions" in
     let message () =
       Format.asprintf "string concatenation is not supported yet" in
-    let expr_loc = Raw.region_of_expr expr in
+    let expr_loc = Raw.expr_to_region expr in
     let data = [
       ("expr_loc",
        fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
@@ -86,7 +86,7 @@ module Errors = struct
     let title () = "tuple pattern" in
     let message () =
       Format.asprintf "tuple patterns are not supported yet" in
-    let pattern_loc = Raw.region_of_pattern p in
+    let pattern_loc = Raw.pattern_to_region p in
     let data = [
       ("pattern_loc",
        fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
@@ -97,7 +97,7 @@ module Errors = struct
     let title () = "constant constructor" in
     let message () =
       Format.asprintf "constant constructors are not supported yet" in
-    let pattern_loc = Raw.region_of_pattern p in
+    let pattern_loc = Raw.pattern_to_region p in
     let data = [
       ("pattern_loc",
        fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
@@ -109,7 +109,7 @@ module Errors = struct
     let message () =
       Format.asprintf "non-variable patterns in constructors \
                        are not supported yet" in
-    let pattern_loc = Raw.region_of_pattern p in
+    let pattern_loc = Raw.pattern_to_region p in
     let data = [
       ("pattern_loc",
        fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
@@ -129,7 +129,7 @@ module Errors = struct
     let title () = "constructors in patterns" in
     let message () =
       Format.asprintf "currently, only constructors are supported in patterns" in
-    let pattern_loc = Raw.region_of_pattern p in
+    let pattern_loc = Raw.pattern_to_region p in
     let data = [
       ("pattern_loc",
        fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
@@ -146,6 +146,18 @@ module Errors = struct
        fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
     ] in
     error ~data title message
+
+  let corner_case ~loc message =
+    let title () = "corner case" in
+    let content () = "We don't have a good error message for this case. \
+                      We are striving find ways to better report them and \
+                      find the use-cases that generate them. \
+                      Please report this to the developers." in
+    let data = [
+      ("location" , fun () -> loc) ;
+      ("message" , fun () -> message) ;
+    ] in
+    error ~data title content
 end
 
 open Errors
@@ -559,14 +571,14 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
       let {name;type_expr} : Raw.type_decl = x.value in
       let%bind type_expression = simpl_type_expression type_expr in
       ok @@ loc x @@ Declaration_type (name.value , type_expression)
-  | LetEntry x (* -> simple_fail "no entry point yet" *)
+  | LetEntry x
   | Let x -> (
       let _ , binding = x.value in
       let {bindings ; lhs_type ; let_rhs} = binding in
       let%bind (var , args) =
         let%bind (hd , tl) =
           match bindings with
-          | [] -> simple_fail "let without bindings"
+          | [] -> fail @@ corner_case ~loc:__LOC__ "let without bindings"
           | hd :: tl -> ok (hd , tl)
         in
         let%bind var = pattern_to_var hd in
diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml
index c5af5e80c..cc5a027f9 100644
--- a/src/simplify/pascaligo.ml
+++ b/src/simplify/pascaligo.ml
@@ -14,6 +14,94 @@ let pseq_to_list = function
   | Some lst -> npseq_to_list lst
 let get_value : 'a Raw.reg -> 'a = fun x -> x.value
 
+module Errors = struct
+  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
+    let data = [
+      ("declaration",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_proc_decl decl =
+    let title () = "procedure declarations" in
+    let message () =
+      Format.asprintf "procedures are not supported yet" in
+    let data = [
+      ("declaration",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_local_proc region =
+    let title () = "local procedure declarations" in
+    let message () =
+      Format.asprintf "local procedures are not supported yet" in
+    let data = [
+      ("declaration",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
+    ] in
+    error ~data title message
+
+  let corner_case ~loc message =
+    let title () = "corner case" in
+    let content () = "We don't have a good error message for this case. \
+                      We are striving find ways to better report them and \
+                      find the use-cases that generate them. \
+                      Please report this to the developers." in
+    let data = [
+      ("location" , fun () -> loc) ;
+      ("message" , fun () -> message) ;
+    ] in
+    error ~data title content
+
+  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.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_string_catenation expr =
+    let title () = "string expressions" in
+    let message () =
+      Format.asprintf "string concatenation 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_set_expr expr =
+    let title () = "set expressions" in
+    let message () =
+      Format.asprintf "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
+end
+
+open Errors
 open Operators.Simplify.Pascaligo
 
 let r_split = Location.r_split
@@ -26,7 +114,7 @@ let return expr = ok @@ fun expr'_opt ->
 
 let return_let_in ?loc binder rhs = ok @@ fun expr'_opt ->
   match expr'_opt with
-  | None -> simple_fail "missing return" (* Hard to explain. Shouldn't happen in prod. *)
+  | None -> fail @@ corner_case ~loc:__LOC__ "missing return"
   | Some expr' -> ok @@ e_let_in ?loc binder rhs expr'
 
 let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
@@ -48,7 +136,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       let lst = npseq_to_list tuple.value.inside in
       let%bind lst' = bind_list @@ List.map simpl_type_expression lst in
       let%bind cst =
-        trace_option (simple_error "unrecognized type constants") @@
+        trace_option (unknown_predefined_type name) @@
         List.assoc_opt name.value type_constants in
       ok @@ T_constant (cst , lst')
   | TProd p ->
@@ -57,9 +145,11 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       ok tpl
   | TRecord r ->
       let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in
+      let apply =
+        fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type) in
       let%bind lst = bind_list
         @@ List.map aux
-        @@ List.map (fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type))
+        @@ List.map apply
         @@ pseq_to_list r.value.elements in
       let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
       ok @@ T_record m
@@ -194,18 +284,20 @@ let rec simpl_expression (t:Raw.expr) : expr result =
       let n = Z.to_int @@ snd @@ n in
       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) ->
     let (s , loc) = r_split s in
       let s' =
         (* S contains quotes *)
-        String.(sub s 1 ((length s) - 2))
+        String.(sub s 1 (length s - 2))
       in
       return @@ e_literal ~loc (Literal_string s')
-  | EString _ -> simple_fail "string: not supported yet"
+  | EString (Cat _) as e ->
+      fail @@ unsupported_string_catenation e
   | ELogic l -> simpl_logic_expression l
   | EList l -> simpl_list_expression l
-  | ESet _ -> simple_fail "set: not supported yet"
+  | ESet _ -> fail @@ unsupported_set_expr t
   | ECase c -> (
       let (c , loc) = r_split c in
       let%bind e = simpl_expression c.expr in
@@ -224,10 +316,11 @@ let rec simpl_expression (t:Raw.expr) : expr result =
       let (mi , loc) = r_split mi in
       let%bind lst =
         let lst = List.map get_value @@ pseq_to_list mi.elements in
-        let aux : Raw.binding -> (expression * expression) result = fun b ->
-          let%bind src = simpl_expression b.source in
-          let%bind dst = simpl_expression b.image in
-          ok (src, dst) in
+        let aux : Raw.binding -> (expression * expression) result =
+          fun b ->
+            let%bind src = simpl_expression b.source in
+            let%bind dst = simpl_expression b.image in
+            ok (src, dst) in
         bind_map_list aux lst in
       return @@ e_map ~loc lst
     )
@@ -309,26 +402,20 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
   match lst with
   | [] -> return @@ e_literal Literal_unit
   | [hd] -> simpl_expression hd
-  | lst -> (
+  | lst ->
       let%bind lst = bind_list @@ List.map simpl_expression lst in
       return @@ e_tuple ?loc lst
-    )
 
 and simpl_local_declaration : Raw.local_decl -> _ result = fun t ->
   match t with
-  | LocalData d -> simpl_data_declaration d
-  | LocalLam l -> simpl_lambda_declaration l
-
-and simpl_lambda_declaration : Raw.lambda_decl -> _ result = fun l ->
-  match l with
-  | FunDecl f -> (
+  | LocalData d ->
+      simpl_data_declaration d
+  | LocalFun f  ->
       let (f , loc) = r_split f in
       let%bind (name , e) = simpl_fun_declaration ~loc f in
       return_let_in ~loc name e
-    )
-  | ProcDecl _ -> simple_fail "no local procedure yet"
-  | EntryDecl _ -> simple_fail "no local entry-point yet"
-
+  | LocalProc d ->
+      fail @@ unsupported_local_proc d.Region.region
 and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
   match t with
   | LocalVar x ->
@@ -344,7 +431,8 @@ and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
       let%bind expression = simpl_expression x.init in
       return_let_in ~loc (name , Some t) expression
 
-and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t ->
+and simpl_param : Raw.param_decl -> (type_name * type_expression) result =
+  fun t ->
   match t with
   | ParamConst c ->
       let c = c.value in
@@ -357,11 +445,15 @@ and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t
       let%bind type_expression = simpl_type_expression c.param_type in
       ok (type_name , type_expression)
 
-and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result = fun ~loc x ->
+and simpl_fun_declaration :
+  loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result =
+  fun ~loc x ->
   let open! Raw in
   let {name;param;ret_type;local_decls;block;return} : fun_decl = x in
   (match npseq_to_list param.value.inside with
-   | [] -> simple_fail "function without parameters are not allowed"
+   | [] ->
+       fail @@
+       corner_case ~loc:__LOC__ "parameter-less function should not exist"
    | [a] -> (
        let%bind input = simpl_param a in
        let name = name.value in
@@ -390,7 +482,7 @@ and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression op
          (arguments_name , type_expression) in
        let%bind tpl_declarations =
          let aux = fun i x ->
-           let expr = e_accessor (e_variable arguments_name) [ Access_tuple i ] in
+           let expr = e_accessor (e_variable arguments_name) [Access_tuple i] in
            let type_ = Some (snd x) in
            let ass = return_let_in (fst x , type_) expr in
            ass
@@ -407,12 +499,14 @@ and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression op
        let%bind result =
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
-       let expression = e_lambda ~loc binder (Some input_type) (Some output_type) result in
+       let expression =
+         e_lambda ~loc binder (Some input_type) (Some output_type) result in
        let type_annotation = Some (T_function (input_type, output_type)) in
        ok ((name.value , type_annotation) , expression)
      )
   )
-and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t ->
+and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
+  fun t ->
   let open! Raw in
   match t with
   | TypeDecl x -> (
@@ -434,15 +528,19 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
       let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in
       ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr))
     )
-  | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet"
-  | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet"
+  | LambdaDecl (ProcDecl decl) ->
+      fail @@ unsupported_proc_decl decl
+  | LambdaDecl (EntryDecl decl) ->
+      fail @@ unsupported_entry_decl decl
 
-and simpl_statement : Raw.statement -> (_ -> expression result) result = fun s ->
+and simpl_statement : Raw.statement -> (_ -> expression result) result =
+  fun s ->
   match s with
   | Instr i -> simpl_instruction i
   | Data d -> simpl_data_declaration d
 
-and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result = fun t ->
+and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result =
+  fun t ->
   match t with
   | ProcCall _ -> simple_fail "no proc call"
   | Fail e -> (