diff --git a/CHANGES.md b/CHANGES.md index 1ab987962..6b6d741f6 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,8 @@ unreleased ------------------ +- Ast_pattern now has ebool, pbool helper, and a new map.(#402, @burnleydev1) + - multiple errors are now reported in `metaquot`. (#397, @burnleydev1) - Add `Attribute.declare_with_attr_loc` (#396, @dvulakh) diff --git a/src/ast_pattern.ml b/src/ast_pattern.ml index 36ebcb01b..84cf29e91 100644 --- a/src/ast_pattern.ml +++ b/src/ast_pattern.ml @@ -66,6 +66,14 @@ let int64 v = cst ~to_string:Int64.to_string v let nativeint v = cst ~to_string:Nativeint.to_string v let bool v = cst ~to_string:Bool.to_string v +let bool' (T func) = + T + (fun ctx loc x k -> + match x with + | "true" -> func ctx loc true k + | "false" -> func ctx loc false k + | _ -> fail loc "Bool") + let false_ = T (fun ctx loc x k -> @@ -175,6 +183,9 @@ let map1' (T func) ~f = let map2' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f loc a b))) +let map_value (T func) ~f = T (fun ctx loc x k -> func ctx loc (f x) k) +let map_value' (T func) ~f = T (fun ctx loc x k -> func ctx loc (f loc x) k) + let alt_option some none = alt (map1 some ~f:(fun x -> Some x)) (map0 none ~f:None) @@ -221,6 +232,8 @@ let pint64 t = ppat_constant (const_int64 t) let pnativeint t = ppat_constant (const_nativeint t) let single_expr_payload t = pstr (pstr_eval t nil ^:: nil) let no_label t = cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel") ** t +let ebool t = pexp_construct (lident (bool' t)) none +let pbool t = ppat_construct (lident (bool' t)) none let extension (T f1) (T f2) = T diff --git a/src/ast_pattern.mli b/src/ast_pattern.mli index 207830318..7515836fe 100644 --- a/src/ast_pattern.mli +++ b/src/ast_pattern.mli @@ -118,6 +118,8 @@ val map2' : f:(Location.t -> 'v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t +val map_value : ('a, 'b, 'c) t -> f:('d -> 'a) -> ('d, 'b, 'c) t +val map_value' : ('a, 'b, 'c) t -> f:(location -> 'd -> 'a) -> ('d, 'b, 'c) t val nil : (_ list, 'a, 'a) t val ( ^:: ) : ('a, 'b, 'c) t -> ('a list, 'c, 'd) t -> ('a list, 'b, 'd) t val many : ('a, 'b -> 'c, 'c) t -> ('a list, 'b list -> 'c, 'c) t @@ -129,6 +131,8 @@ val int32 : int32 -> (int32, 'a, 'a) t val int64 : int64 -> (int64, 'a, 'a) t val nativeint : nativeint -> (nativeint, 'a, 'a) t val bool : bool -> (bool, 'a, 'a) t +val ebool : (bool, 'a, 'b) t -> (expression, 'a, 'b) t +val pbool : (bool, 'a, 'b) t -> (pattern, 'a, 'b) t val cst : to_string:('a -> string) -> ?equal:('a -> 'a -> bool) -> 'a -> ('a, 'b, 'b) t