Finished changing the error reporting.

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 (
+  trace (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
-  ) @@
   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
-    | _ ->
+    | PPar p -> get_var p.value.inside
-        let error =
+    | _ -> fail @@ unsupported_non_var_pattern t
-          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
   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
+    ok (List.hd t')
-  let get_constr (t:Raw.pattern) = match t with
+  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 =