From 4f60f2376905523ce3544836d1603f3de55272f8 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Tue, 4 Jun 2019 13:45:21 +0200 Subject: [PATCH] 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 =