diff options
Diffstat (limited to 'src/pattern_completeness.ml')
| -rw-r--r-- | src/pattern_completeness.ml | 36 |
1 files changed, 14 insertions, 22 deletions
diff --git a/src/pattern_completeness.ml b/src/pattern_completeness.ml index 79fc93ee..afda3e1a 100644 --- a/src/pattern_completeness.ml +++ b/src/pattern_completeness.ml @@ -68,7 +68,6 @@ type gpat = | GP_cons of gpat * gpat | GP_or of gpat * gpat | GP_app of (gpat Bindings.t) - | GP_record of (gpat Bindings.t) | GP_string_append of gpat list let rec string_of_gpat = function @@ -82,7 +81,6 @@ let rec string_of_gpat = function | GP_or (gpat1, gpat2) -> string_of_gpat gpat1 ^ " | " ^ string_of_gpat gpat2 | GP_app app -> Util.string_of_list "|" (fun (id, gpat) -> string_of_id id ^ string_of_gpat gpat) (Bindings.bindings app) - | GP_record _ -> "GP RECORD" | GP_string_append gpats -> Util.string_of_list " ^^ " string_of_gpat gpats let is_wild = function @@ -106,7 +104,7 @@ let rec generalize ctx (P_aux (p_aux, (l, _)) as pat) = | Unbound -> GP_wild | Local (Immutable, _) -> GP_wild | Register _ | Local (Mutable, _) -> - Util.warn ("Matching on register or mutable variable at " ^ Reporting.loc_to_string l); GP_wild + Reporting.warn "Matching on register or mutable variable at " l ""; GP_wild | Enum _ -> GP_app (Bindings.singleton id GP_wild) end | P_var (pat, _) -> generalize ctx pat @@ -135,15 +133,6 @@ let rec generalize ctx (P_aux (p_aux, (l, _)) as pat) = GP_app (Bindings.singleton f GP_wild) else GP_app (Bindings.singleton f (GP_tup gpats)) - | P_record (fpats, flag) -> - let gfpats = List.concat (List.map (generalize_fpat ctx) fpats) in - GP_record (List.fold_left (fun m (fid, gpat) -> Bindings.add fid gpat m) Bindings.empty gfpats) - -and generalize_fpat ctx (FP_aux (FP_Fpat (field_id, pat), annot)) = - let gpat = generalize ctx pat in - if is_wild gpat then [] - else - [(field_id, gpat)] let vector_pat bits = let bit_pat = function @@ -164,7 +153,7 @@ let join_bits bits1 bits2 = (* The join_lit function takes two patterns and produces a pattern that matches both literals *) -let rec join_lit (L_aux (l_aux1, _) as lit1) (L_aux (l_aux2, _) as lit2) = +let rec join_lit (L_aux (l_aux1, l) as lit1) (L_aux (l_aux2, _) as lit2) = match l_aux1, l_aux2 with (* The only literal with type unit is the unit literal *) | L_unit, _ -> GP_lit lit1 @@ -207,7 +196,7 @@ let rec join_lit (L_aux (l_aux1, _) as lit1) (L_aux (l_aux2, _) as lit2) = Printf.sprintf "Have two differently typed pattern literals %s and %s matching the same thing" (string_of_lit lit1) (string_of_lit lit2) in - Util.warn message; + Reporting.warn "" l message; GP_wild let rec join ctx gpat1 gpat2 = @@ -270,7 +259,7 @@ let combine ctx gpat (l, pat) = (* This warning liable to false positives as join returns a pattern that overapproximates what can match, so we only report when the second match is a constructor. *) - Util.warn (Printf.sprintf "Possible redundant pattern match at %s\n" (Reporting.loc_to_string l)); + Reporting.warn "Possible redundant pattern match at" l ""; GP_wild | _, gpat' -> join ctx gpat gpat' @@ -286,17 +275,20 @@ let shrink_loc = function Lexing.(Parse_ast.Range (n, { n with pos_cnum = n.pos_cnum + 5 })) | l -> l +let is_complete ctx cases = + match cases_to_pats cases with + | [] -> false + | (_, pat) :: pats -> + let top_pat = List.fold_left (combine ctx) (generalize ctx pat) pats in + is_wild top_pat + let check l ctx cases = match cases_to_pats cases with - | [] -> Util.warn (Printf.sprintf "No non-guarded patterns at %s\n" (Reporting.loc_to_string (shrink_loc l))) + | [] -> Reporting.warn "No non-guarded patterns at" (shrink_loc l) "" | (_, pat) :: pats -> let top_pat = List.fold_left (combine ctx) (generalize ctx pat) pats in if is_wild top_pat then () else - let message = - Printf.sprintf "Possible incomplete pattern match at %s\n\nMost general matched pattern is %s\n" - (Reporting.loc_to_string (shrink_loc l)) - (string_of_gpat top_pat |> Util.cyan |> Util.clear) - in - Util.warn message + Reporting.warn "Possible incomplete pattern match at" (shrink_loc l) + (Printf.sprintf "Most general matched pattern is %s" (string_of_gpat top_pat |> Util.cyan |> Util.clear)) |