From 8b59222d01c16dfa4de05791837dcceeae108515 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Wed, 30 Oct 2019 15:34:15 +0100 Subject: [PATCH] typedtree: make the Tpat_value argument a private synonym This prevents users from mistakenly constructing a Tpat_value pattern using the natural implementation { pat with pat_desc = Tpat_value pat } which breaks the attributes-placement invariant (the attributes are duplicated with this version, instead of being placed only on the value pattern, with empty attributes on the computation pattern). (Suggestion from Jacques Garrigue.) --- typing/printpat.ml | 2 +- typing/printtyped.ml | 2 +- typing/rec_check.ml | 2 +- typing/tast_iterator.ml | 2 +- typing/tast_mapper.ml | 2 +- typing/typedtree.ml | 4 +++- typing/typedtree.mli | 11 +++++++---- typing/untypeast.ml | 2 +- 8 files changed, 16 insertions(+), 11 deletions(-) diff --git a/typing/printpat.ml b/typing/printpat.ml index dec79b769..fcac98925 100644 --- a/typing/printpat.ml +++ b/typing/printpat.ml @@ -95,7 +95,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | Tpat_alias (v, x,_) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_value v -> - fprintf ppf "%a" pretty_val v + fprintf ppf "%a" pretty_val (v :> pattern) | Tpat_exception v -> fprintf ppf "@[<2>exception@ %a@]" pretty_arg v | Tpat_or _ -> diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 1430ffae9..0908630a6 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -261,7 +261,7 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> pattern i ppf p; | Tpat_value p -> line i ppf "Tpat_value\n"; - pattern i ppf p; + pattern i ppf (p :> pattern); | Tpat_or (p1, p2, _) -> line i ppf "Tpat_or\n"; pattern i ppf p1; diff --git a/typing/rec_check.ml b/typing/rec_check.ml index 32484f7a7..de4420957 100644 --- a/typing/rec_check.ml +++ b/typing/rec_check.ml @@ -1197,7 +1197,7 @@ and is_destructuring_pattern : type k . k general_pattern -> bool = | Tpat_record (_, _) -> true | Tpat_array _ -> true | Tpat_lazy _ -> true - | Tpat_value pat -> is_destructuring_pattern pat + | Tpat_value pat -> is_destructuring_pattern (pat :> pattern) | Tpat_exception _ -> false | Tpat_or (l,r,_) -> is_destructuring_pattern l || is_destructuring_pattern r diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index 01326e7dd..db63fc0b7 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -170,7 +170,7 @@ let pat | Tpat_array l -> List.iter (sub.pat sub) l | Tpat_alias (p, _, _) -> sub.pat sub p | Tpat_lazy p -> sub.pat sub p - | Tpat_value p + | Tpat_value p -> sub.pat sub (p :> pattern) | Tpat_exception p -> sub.pat sub p | Tpat_or (p1, p2, _) -> sub.pat sub p1; diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 9bcc6df58..d8ceee1d9 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -221,7 +221,7 @@ let pat | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) | Tpat_value p -> - Tpat_value (sub.pat sub p) + (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc | Tpat_exception p -> Tpat_exception (sub.pat sub p) | Tpat_or (p1, p2, rd) -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 6a6319a97..328145398 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -71,13 +71,15 @@ and 'k pattern_desc = | Tpat_array : value general_pattern list -> value pattern_desc | Tpat_lazy : value general_pattern -> value pattern_desc (* computation patterns *) - | Tpat_value : value general_pattern -> computation pattern_desc + | Tpat_value : tpat_value_argument -> computation pattern_desc | Tpat_exception : value general_pattern -> computation pattern_desc (* generic constructions *) | Tpat_or : 'k general_pattern * 'k general_pattern * row_desc option -> 'k pattern_desc +and tpat_value_argument = value general_pattern + and expression = { exp_desc: expression_desc; exp_loc: Location.t; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 9c25e18d8..fea034970 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -117,7 +117,7 @@ and 'k pattern_desc = | Tpat_lazy : value general_pattern -> value pattern_desc (** lazy P *) (* computation patterns *) - | Tpat_value : value general_pattern -> computation pattern_desc + | Tpat_value : tpat_value_argument -> computation pattern_desc (** P Invariant: Tpat_value pattern should not carry @@ -126,9 +126,10 @@ and 'k pattern_desc = facilitate searching for a certain value pattern constructor with a specific attributed. - To enforce this restriction it suffices to use the - [as_computation_pattern] function below instead of the - [Tpat_value] constructor directly. + To enforce this restriction, we made the argument of + the Tpat_value constructor a private synonym of [pattern], + requiring you to use the [as_computation_pattern] function + below instead of using the [Tpat_value] constructor directly. *) | Tpat_exception : value general_pattern -> computation pattern_desc (** exception P *) @@ -142,6 +143,8 @@ and 'k pattern_desc = [None] otherwise. *) +and tpat_value_argument = private value general_pattern + and expression = { exp_desc: expression_desc; exp_loc: Location.t; diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 5540e5bad..fe110bf98 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -349,7 +349,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) | Tpat_exception p -> Ppat_exception (sub.pat sub p) - | Tpat_value p -> (sub.pat sub p).ppat_desc + | Tpat_value p -> (sub.pat sub (p :> pattern)).ppat_desc | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) in Pat.mk ~loc ~attrs desc